pbfree lade Musik Title CD info von FreeDB sever automatisch

[Peter Weis]

Habe wieder mal was aufgearbeitet für PBwin 10 werde den Quellcode in den Nächsten Tagen veröffentlichen. Muss  noch ein paar Sachen aufarbeiten. ist ein COM Objekt lässt sich von Excel und Word aufrufen, geht aber auch eigenständig!  Hiermit lässt sich eine Audio CD auslesen und eine CD Datenbank erstellen. Das Objekt ließt automatisch aus dem Internet Titel einer CD

Den Quellcode habe ich dazu gepackt!

Grüße Peter

[Patrice Terrier]

Google translation:

Have again what worked for PBwin 10 will release the source code in the next days. Still needs a few things worked up. is a COM object can be called from Excel and Word, but is also independently! This allows to read an audio CD and create a CD database. The object reads from the Internet automatically tracks on a CD

So here's the source code

[Peter Weis]

Hallo

Um das Objekt in Excel oder Word zu nutzen muss folgendes Programm als Administrator ausgeführt werden

Code: [Select]

'------------------------------------------------------------------------------
'
'  Register the pbfree.dll COM Server
'  Copyright (c) 2014 Peter Weis
'  All Rights Reserved.
'
'
'------------------------------------------------------------------------------

#COMPILE EXE
#DIM ALL

DECLARE FUNCTION DllRegisterServer LIB ".\pbfreedb.dll" ALIAS "DllRegisterServer"   AS LONG

FUNCTION PBMAIN () AS LONG
  LOCAL i AS LONG

  i = DllRegisterServer
  IF i = %S_OK THEN
    ? "Registration of PBFREEDB.dll was successful"
  ELSE
    ? "Registration of PBFREEDB.dll has failed"
  END IF

END FUNCTION
                             



in Windows XP geht das aber einfacher man braucht nur pbfreedb mit regsvr32 auszuführen!

Habe das Project neu gepackt und oben dazu gefügt

nach dem erfolgreichen registrieren der dll muss im Com Browser folgende Zeile erscheinen

die Einbindung des Objects unter Excel oder Word  bedarf es leider einer 32Bit Version von Excel oder Word In der 64 Bit Version geht es nicht! Beispiel und Beschreibung folgt!

Ist das Hauptprogramm in PowerBASIC geschrieben geht es auch mit Excel und Word 64!   

[Peter Weis]

Nächster Schritt für die Verwendung mit Excel. Das gilt für Office ab Version 2007! Bei früheren Versionen ist das nicht nötig!

Die Entwickler Tools müssen eingeschaltet werden.



Das geht so wie oben im Bild beschrieben.

Also Excel Optionen einstellen!

Dabei Entwickler Tools aktivieren

Excel müßte dann so ausschauen das Tab mit Entwickler Tools siehe Bild unten müßte erscheinen.



Als nächstes bitte die das Tab Entwickler Tools anwählen das erscheint das Button „Code Anzeigen“ das müssen sie auswählen



Es erscheint dann die VBA Umgebung von Excel. Bitte wählen sie hier den Menüpunkt „Extras“ an!



Hier dann den Menüpunkt Verweise auswählen.



Hier bitte den Verweis pbfreedb anwählen. Danach kann dann das VBA Programm geschrieben werden das das Objekt nutzt

[Peter Weis]

Hallo,
Wichtig ist dem Objekt die Objekt Variable zu übergeben! da diese intern für Funktionen benötigt wird

Code: [Select]

Public Sub freedbinit()

Set cfreedb = New FREEDB

initcfreedb cfreedb

   
    App.Title = ThisWorkbook.Name
    App.Major = "1"
    App.Minor = "1"
   
    combo3() = Split(cfreedb.GETCDROMS, "|")
   
    cda = 1
    For i = LBound(combo3) To UBound(combo3)

        If cfreedb.GetMediaInfo(combo3(i)) <> "" Then
            CdAudio = cda
            Exit For
        End If
        cda = cda + 1
    Next i
   
    cfreedb.APPNAME = App.Title
    cfreedb.APPVERSION = App.Major & "." & App.Minor

    cfreedb.EMAILADDRESS = "peter.weis@freenet.de"
    cfreedb.CDDBSERVER = "freedb.freedb.org"

    cfreedb.CDDBINTERFACE = AUTO
    cfreedb.CDDBMODE = SUBMIT                 '%TEST
    cfreedb.USEFIRSTMATCH = True
    cfreedb.ALLOWSUBMISSION = False
    cfreedb.INTERNETENABLE = True
    With UserForm1
   
        .CommandButton1.Enabled = False
   
                                         
        For i = 0 To UBound(combo3()) - 1
            .ComboBox1.AddItem (combo3(i))
       
        Next i
    End With
   
End Sub



[Peter Weis]

Im Übrigen habe das Objekt an die neuen Versionen von Office angepasst da die nur noch mit Unicode Strings zurechtkommen. Das Objekt steht oben zum Download bereit

[Peter Weis]

Hallo Freunde,

Hab festgestellt das es noch zwei Probleme bei der Anbindung an  Excel gibt ein Problem ist, das Excel das Laufwerk nicht mehr frei gibt das einmal gescannt wurde! komischerweise hatte ich das Problem nicht mit älteren Versionen von Excel.

Das andere Problem ist das PowerBasic die Attribute bei der Parameterübergabe nicht in die Typelib schreibt was ich schon in der Version 9 von PowerBASIC moniert habe! So können keine Optionalen Parameter übergeben werden

Bin aber dran die Probleme zum Beseitigen!

Grüße Peter

[Peter Weis]

Hallo,
sieht doch heute mal nicht schlecht aus bin weiter gekommen.
Wie man sieht liest das Objekt von CD und holt sich dann die dazugehörigen Titel aus dem Internet


Dafür müssen aber die Makros in Excel   für die Tabelle aktiviert werden siehe hier



Im nächsten Schritt muss der Makro gestartet werden.



Dann sollte dieser einfache Dialog erscheinen. Bei dem man das CD Laufwerk auswählt das Button sollte dann freigegeben werden! Und man kann sich die Daten aus dem Internet holen. Natürlich muss auch eine Audio CD im Laufwerk liegen



Den Code hab ich natürlich wieder oben dazu gelegt!

[Peter Weis]

Das Com Objekt beinhaltet auch noch mehrere Dialog. z.B die Serverauswahl oder wen mehrere Möglichkeiten auf dem Server liegen! Damit man darauf einen Zugriff hat muss man dem Objekt das Handle des aktuellen Fenster übergeben. das hat mir wirklich etwas Kopfzerbrechen bereitet. Da man in VBA eigentlich nicht mit Handles arbeitet. Habe aber eine Lösung gefunden!

Code: [Select]


Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
    (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Sub CommandButton1_Click()
    Call sethandle(whandle)
    Call BUTTONQUERY
    UserForm1.Hide
   
End Sub

Private Sub UserForm_Activate()
   
    If Val(Application.Version) >= 9 Then
        whandle = FindWindow("ThunderDFrame", Me.Caption)
    Else
        whandle = FindWindow("ThunderXFrame", Me.Caption)
    End If
   
   
End Sub
   



Ergebnis wen mehrere Titel von einer CD auf Server Liegen. Habe wieder alles gepackt und am ersten Topic hinzugefügt

Grüße Peter
 

[Peter Weis]

Hallo ,
Eigentlich wollte ich jetzt daran arbeiten wie man die Typelib verändern kann, so das man auch Optionale Parameter nutzen kann. Nach dem ich aber im Internet gelesen hab das das Vivian Zale in den nächsten Tagen was neues bringen möchte, weil sie ein neues Team hat warte ich da mal! Werde ich euch mal aufzeigen wie man nach verschiedenen Methoden mit  dem Objekt suchen kann!

Einmal klar über freedb server

Zum zweiten über FREEDB Files die sich am Rechner befinden. Dafür muss die Datenbank hier herunter geholt werden http://www.freedb.org/en/download__database.10.html und entpackt  werden



Zum dritten über DAO Datenbank. Die aber noch ein Problem hat weil die Datenbank über zwei  Gig hat  dieses Problem muss ich auch noch lösen. Mikrosoft Access  lässt  nämlich nur zwei  Gig zu. Ich muss die Datenbank splitten.


 

[Peter Weis]

Etwas verrückt aber es ist so 

VBA unterstützt bei Aufruf von Funktionen in DLL nur ANSI Strings, keine Unicode Strings. Bei Objekten ist das anders da werden nur Unicode Strings erwartet.

Code: [Select]

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
    ByVal lpClassName As String, ByVal lpWindowName As String) As Long
   
   
Private Declare Function BrowseForDirectoryA Lib "pbfreedb" ( _
    ByVal hwnd As Long, _
    ByVal Title As String, _
    Optional showFiles As Integer, _
    Optional startDir As String) As String

 

[Peter Weis]

habe die Funktionen BrowseForDirectoryA und BrowseForDirectoryW umgeschrieben und durch neuen Dialog Style ersetzt schaut moderner aus und ist hundert mal schneller als der alte Dialog.

Code: [Select]

'*****************************************
'** Browse for Directory / Files Dialog **
'*****************************************
FUNCTION BrowseForDirectoryW ALIAS "BrowseForDirectoryW" (BYVAL hwnd AS LONG, BYVAL Title AS WSTRING, _
                                   BYVAL uflags AS LONG, _
                                   OPT startDir AS WSTRING) EXPORT AS WSTRING
    DIM lpIDList AS LONG
    DIM iNull AS INTEGER
    DIM sPath AS WSTRINGZ * %MAX_PATH
    DIM BrInfo AS BrowseInfoW
    STATIC zstartDir AS WSTRINGZ * %MAX_PATH


    BrInfo.hWndOwner    = hwnd
    BrInfo.lpszTitle    = STRPTR(Title)
    zstartdir           = startDir
    BrInfo.lparam       = VARPTR(zstartdir)
    BrInfo.ulFlags      = uflags OR %BIF_NEWDIALOGSTYLE
    BrInfo.pidlroot     = 0
    BrInfo.lpfnCallback = CODEPTR(BrowseCallbackProcW)

    'set for call back...
    'm_CurrentDirectoryW = startDir

    'pop up dialog...
    lpIDList = SHBrowseForFolderW(BrInfo)
    IF (lpIDList) THEN
        'sPath = Space$(260)

        'convert id to path
        IF SHGetPathFromIDListW(BYVAL lpIDList, sPath) THEN
            BrowseForDirectoryW = sPath
        END IF

        'we must free the memory...
        CALL CoTaskMemFree(lpIDList)
    END IF
END FUNCTION
                         


[Peter Weis]

Hallo habe wieder ein paar Änderungen vorgenommen damit die Sache stabiler läuft

zum ersten habe ich die Objekte die das Interface ICollection benötigen nicht mehr Global definiert sondern sondern als Instanz definiert!



der Aufruf bei global war unter Excel nur einmal möglich!

Code: [Select]

    INSTANCE colTrackNames          AS ICollection
    INSTANCE colTrackCDNames        AS ICollection
    INSTANCE colTrackTimes          AS ICollection
    INSTANCE colTrackNotes          AS ICollection
    INSTANCE colServers             AS ICollection
                                                   


dafür musste ich aber  die Funktion DetectAudio in die Classe als CLASS Methode aufnehmen die vorher außerhalb war

Zum zweiten habe ich einen Timer eingefügt der während der Laufzeit überwacht ob das CD Laufwerk eine Audio-CD enthält!

Code: [Select]

Option Explicit
Public Declare Sub initcfreedb Lib "pbfreedb.dll" Alias "inintcfreedb" (par As PFREEDB)
Private Declare Function FindWindow Lib "user32" Alias "FindWindowW" _
    (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
   
Private Declare Function SetTimer Lib "user32.dll" ( _
  ByVal hWnd As Long, _
  ByVal nIDEvent As Long, _
  ByVal uElapse As Long, _
  ByVal lpTimerFunc As Long) As Long
 
Private Declare Function KillTimer Lib "user32.dll" ( _
  ByVal hWnd As Long, _
  ByVal nIDEvent As Long) As Long
 
Private Declare Function GetDriveType Lib "kernel32.dll" _
  Alias "GetDriveTypeA" ( _
  ByVal nDrive As String) As Long
 
 
Const WM_TIMER = &H113 ' Timer-Ereignis trifft ein
   
Private hEvent As Long
Private TocTxT As String
       



Const MAX_PATH = 260
Const MATCH_NONE = 0
Const AUTO = 0
Const SUBMIT = 1
Const MCI = 3
Const SPI = 1

Const DRIVE_CDROM = 5




Private Type AppType
    Title       As String * 50
    Major       As String * 4
    Minor       As String * 4
    Revision    As String * 4
    PATH        As String * MAX_PATH


End Type

Public Type freedbconfig
    dbfolter            As String * MAX_PATH
    drive               As String * 20
    InternetEnable      As Integer
    QueryLocalDatabase  As Integer
   
   
End Type

Public dbfreec As freedbconfig

                 

Dim App              As AppType

Public cfreedb As FREEDB
Dim combo3() As String

' Timer-Prozedur, welche im Abstand der festgelegten
' Millisekunden ein Ereignis sendet
Public Sub TimerProc(ByVal hWnd As Long, ByVal uMsg As Long, _
  ByVal wParam As Long, ByVal lParam As Long)
 
  'Dim ST As SYSTEMTIME
 
  If uMsg = WM_TIMER Then
    DisableTimer
    initdrive
    EnableTimer 200
    ' Lokale Zeit ermitteln...
    ' GetLocalTime ST
 
    ' ... und im Labelfeld der Form anzeigen
    'Form1.Label1.Caption = Format$(ST.wHour, "00:") & _
    '  Format$(ST.wMinute, "00:") & Format$(ST.wSecond, "00 Uhr")
  End If
End Sub


' Startet den Timer
Public Function EnableTimer(ByVal msInterval As Long)
  If hEvent <> 0 Then Exit Function
  hEvent = SetTimer(0&, 0&, msInterval, AddressOf TimerProc)
End Function

' Beendet den Timer
Public Function DisableTimer()
  If hEvent = 0 Then Exit Function
  KillTimer 0&, hEvent
  hEvent = 0
End Function



Public Sub freedbinit()
    If cfreedb Is Nothing Then
        Set cfreedb = New FREEDB
        initcfreedb cfreedb
    End If
   
    If cfreedb Is Nothing Then
        MsgBox "Programm kann nicht gestartet werden weil FREEDB nicht geladen wurde"
    Else
        Open "mape1.cfg" For Binary As #1
        Get #1, 1, dbfreec
        Close #1
       
        Dim cda, i, cdaudio As Integer
       
   
        App.Title = ThisWorkbook.Name
        App.Major = "1"
        App.Minor = "1"
   
        combo3() = Split(cfreedb.GetCdRoms, "|")
   
        cda = 1
        For i = LBound(combo3) To UBound(combo3)

            If cfreedb.GetMediaInfo(combo3(i)) <> "" Then
                cdaudio = cda
                Exit For
            End If
            cda = cda + 1
        Next i
       
        EnableTimer 200
   
        cfreedb.APPNAME = App.Title
        cfreedb.APPVERSION = App.Major & "." & App.Minor

        cfreedb.EMAILADDRESS = "peter.weis@freenet.de"
        cfreedb.CDDBSERVER = "freedb.freedb.org"

        cfreedb.CDDBINTERFACE = MCI
        cfreedb.CDDBMODE = SUBMIT                 '%TEST
        cfreedb.UseFirstMatch = False
        cfreedb.ALLOWSUBMISSION = True
        cfreedb.InternetEnable = dbfreec.InternetEnable
        cfreedb.QueryLocalDatabase = dbfreec.QueryLocalDatabase
       
        With UserForm1
   
            .CommandButton1.Enabled = False
   
                                         
            For i = 0 To UBound(combo3()) - 1
                .ComboBox1.AddItem (combo3(i))
               
               
               
            Next i
           
            .OptionButton10.Value = dbfreec.InternetEnable
            .OptionButton1.Value = dbfreec.QueryLocalDatabase
           
            If Trim(dbfreec.drive) <> "" Then
               .ComboBox1.Value = dbfreec.drive
            End If
            .TextBox1.Value = dbfreec.dbfolter
        End With
   
   
    End If

End Sub

Public Sub sethandle(ByVal handle As Long)
    cfreedb.ParentHandle = handle

End Sub

Public Sub BUTTONQUERY()
   
    Dim x As String
    Dim ret As Long
   
    x = cfreedb.pGetMediaTOC
     
       
    If x <> "" Then
        DisableTimer
        If cfreedb.LookupMediaByToc(x) = MATCH_NONE Then
    '        cfreedb.LOOKUPMEDIADIRBYTOC ("")
        End If
   
        If cfreedb.MatchCodeNum <> MATCH_NONE Then
            showInfo
        End If
        EnableTimer 200
    End If
                 

End Sub

Public Sub endprog()
    Set cfreedb = Nothing
    End
   
End Sub


Private Sub showInfo1()
    Dim x, y As Integer
   
    UserForm1.Hide
    Sheets(1).Select
    Cells.Select
    Selection.Delete Shift:=xlUp
    For x = 1 To 3
        For y = 1 To cfreedb.GetAlbumTracks
            Select Case x
                Case 1
                    Cells(y, x).Value = cfreedb.SecondsToTimeString(cfreedb.GetTrackTime(y))
                Case 2
                    Cells(y, x).Value = cfreedb.GetTrackName(y)
                Case 3
                    Cells(y, x).Value = cfreedb.GetTrackNotes(y)
                Case Else
            End Select
        Next y
   
   
    Next x
    Call endprog
End Sub

Public Sub initdrive()
    Dim s As String
   
    If GetDriveType(cfreedb.DriveLetter) = DRIVE_CDROM Then
   
        s = cfreedb.GetMediaTOC(cfreedb.DriveLetter)
        If s <> TocTxT Then
            TocTxT = s
            If TocTxT <> "" Then
                   
                cfreedb.LookupMediaDirByToc (TocTxT)
                showInfo
            Else
                UserForm1.ListView1.ListItems.Clear
            End If
        End If
    End If

End Sub

Private Sub showInfo()
    Dim x, y As Integer
   
    'UserForm1.Hide
    'Sheets(1).Select
    'Cells.Select
    'Selection.Delete Shift:=xlUp
   
    With UserForm1
        .ListView1.ListItems.Clear
        For x = 1 To 4
            For y = 1 To cfreedb.GetAlbumTracks
                Select Case x
                    Case 1
                        .ListView1.ListItems.Add , , Format(y, "##")
                                         
                    Case 2
                        .ListView1.ListItems(y).SubItems(1) = cfreedb.SecondsToTimeString(cfreedb.GetTrackTime(y))
                                       
                    Case 3
                        .ListView1.ListItems(y).SubItems(2) = cfreedb.GetTrackName(y)
                       
                    Case 4
                        .ListView1.ListItems(y).SubItems(3) = cfreedb.GetTrackNotes(y)
                    Case Else
                End Select
            Next y
        Next x
    End With
End Sub



Bin aber noch nicht ganz zufrieden! Ihr hört von mir
 

 
 
 

[Peter Weis]

Hallo,
kleine Ursache große Wirkung. Hatte bei der Übergabe des lokalen Ordner einen String fester Länge übergeben. Bei VBA Also MAX_PATH Zeichen, dieser wird von VBA in kompletter Länge übergeben. Die Methode QueryFlatFileSystem findet aber dann keine Übereinstimmungen mehr weil der Order auf der Festplatte nicht mehr gefunden wird!

Habe nun in Property CDDBFilePath ein Trim$ Funktion eingefügt damit diese Leerzeichen entfernt werden

Code: [Select]

        PROPERTY SET CDDBFilePath ALIAS "CDDBFilePath"(BYVAL strPath AS WSTRING)
            m_strCDDBFilePath = TRIM$(strPath)
        END PROPERTY       

Jetzt funktioniert auch die Suche mit VBA  mit lokaler Datenbank auf Rechner

[Peter Weis]

Hallo,
habe wieder mal ein bisserl was gemacht, habe das konvertieren in eine Access Datenbank umgeschrieben. Da das umwandeln mehrere Std dauert lasse ich das Ganze in einem THREAD im Hintergrund ablaufen, damit man mit dem während der  Zeit auch weiter arbeiten kann. 

Code: [Select]

THREAD FUNCTION CONVERT_MDB(BYVAL hdlg AS LONG) AS LONG
    LOCAL lRslt AS LONG
    LOCAL m_DBEngineidx, m_DBEngine AS Int_DBEngine
    LOCAL m_dbWorkspaces, m_dbWorkspacesidx AS Workspaces
    LOCAL m_dbWorkspace, m_dbWorkspaceidx AS Workspace
    LOCAL dbDatabase, dbDatabaseidx AS Database
    LOCAL dbRecordsetidx, dbRecordset  AS Recordset
    LOCAL dbTableDef       AS Int_TableDef
    LOCAL dbfields         AS fields
    LOCAL dbfield          AS Int_Field
    LOCAL dbTableDefs      AS TableDefs
    LOCAL DatabaseNr, i , dbupdate, Record AS LONG
    LOCAL file, f AS WSTRING
    STATIC dta AS DIRDATA
    LOCAL sFlag AS INTEGER
    DIM sFiles(0 TO 10) AS WSTRING


     'init the catagory array...
    sFiles(0) = "blues": sFiles(1) = "country": sFiles(2) = "classical"
    sFiles(3) = "data":  sFiles(4) = "folk":    sFiles(5) = "jazz"
    sFiles(6) = "misc":  sFiles(7) = "newage":  sFiles(8) = "reggae"
    sFiles(9) = "rock":  sFiles(10) = "soundtrack"

    #IF %DEF($PROGID_DAO_DBEngine36)
        m_DBEngineidx   =  ANYCOM $PROGID_DAO_DBEngine36
        m_DBEngine      =  ANYCOM $PROGID_DAO_DBEngine36
    #ELSE
        m_DBEngineidx   =  ANYCOM $PROGID_DAO_DBEngine120
        m_DBEngine      =  ANYCOM $PROGID_DAO_DBEngine120
    #ENDIF

    IF ISOBJECT(m_DBEngine) AND ISOBJECT (m_DBEngineidx) THEN
        m_dbWorkspaces      = m_DbEngine.Workspaces()
        m_dbWorkspacesidx   = m_DbEngineidx.Workspaces()
        m_dbWorkspace       = m_dbWorkspaces.Item(0)
        m_dbWorkspaceidx    = m_dbWorkspacesidx.Item(0)

    END IF


    IF ISOBJECT (cFREEDB) THEN
        IF cfreedb.DAOUpdateMode = %False THEN
            KILL cFREEDB.DAODir + "\" + "FREEDB*.MDB"


        END IF

        IF ISOBJECT(m_dbWorkspaceidx) AND ISOBJECT (m_dbWorkspace)THEN
            dbDatabaseidx = m_dbWorkspaceidx.OpenDatabase(cFREEDB.DAODir + "\" + "FREEDBIDX.MDB", %False, %False)
            IF ISFALSE ISOBJECT(dbDatabaseidx) THEN
                ERRCLEAR
                dbDatabaseidx = m_dbWorkspaceidx.CreateDatabase(cFREEDB.DAODir + "\" + "FREEDBIDX.MDB", $$dbLangGeneral)
            END IF


            dbrecordset = ObenDataBase(m_dbWorkspace, dbDatabase, DataBaseNr)





            IF ((ISFALSE ISOBJECT(dbDatabaseidx)) OR (ISFALSE ISOBJECT(dbDatabase))) THEN
                MSGBOX "Kann Datenbank FREEDB.MDB öffnen oder erstellen" & $CR & _
                        "Daten können dadurch nicht gespeichert werden", %MB_ICONERROR
                        FUNCTION = 0
                        EXIT FUNCTION
            ELSE
                dbrecordsetidx = dbDatabaseidx.OpenRecordset("FREEDBINDEX", %RecordsetTypeEnum.dbOpenDynaset, %RecordsetOptionEnum.dbDenyRead)
                IF ISFALSE ISOBJECT(dbrecordsetidx) THEN
                    ERRCLEAR
                    dbTableDef  = dbDatabase.CreateTableDef("FREEDBINDEX")
                    dbFields   = dbTableDef.Fields
                    dbfield = dbTableDef.CreateField("DISKID", %DataTypeEnum.dbLong)
                    dbFields.Append dbfield
                    dbfield = dbTableDef.CreateField("DATNR", %DataTypeEnum.dbInteger)
                    dbFields.Append dbfield
                    dbfield = dbTableDef.CreateField("RECNR", %DataTypeEnum.dbLong)
                    dbFields.Append dbfield

                    dbTableDefs = dbdatabaseidx.tabledefs
                    dbTableDefs.Append (dbTabledef)

                    dbDatabaseidx.TableDefs.Refresh
                    dbRecordsetidx  = dbTableDef.OpenRecordset(%RecordsetTypeEnum.dbOpenDynaset, %RecordsetOptionEnum.dbDenyRead)
                    dbField     = NOTHING
                    dbFields    = NOTHING
                    dbTableDef  = NOTHING
                    dbTableDefs = NOTHING




                END IF




                DO
                    IF IsFreeDBFile (cFREEDB.CDDBFilePath, sFiles(i), File, DTA, sFlag) THEN
                        IF FilelenOpen(cFREEDB.DAODir + "\" + "FREEDB" + FORMAT$(DatabaseNr, "00")+ ".MDB" ) > 1000000000 THEN
                            INCR DatabaseNr
                            dbrecordset.Close
                            dbrecordset = NOTHING
                            dbDatabase.close
                            dbDatabase = NOTHING
                            dbrecordset = ObenDataBase(m_dbWorkspace, dbDatabase, DataBaseNr)
                        END IF


                        Record = 0


                        CALL dbsetrecord(file, sfiles(i), DatabaseNr, Record, dbDatabase, dbrecordset)
                        dbrecordsetidx.addnew
                        dbrecordsetidx.collect(0) = VAL("&H"+(File))
                        dbrecordsetidx.collect(1) = DataBaseNr
                        dbrecordsetidx.collect(2) = Record
                        'dbrecordset.collect(1) = PBReadFile(f)
                        dbrecordsetidx.update %UpdateTypeEnum.dbUpdateRegular
                        CONTROL SET TEXT hdlg, %IDC_LABEL8, "FreeDB File: " + File
                        'CONTROL SET TEXT CB.HNDL, %IDC_LABEL9, "MDB Recordset: " + sFiles(I)
                        IF dbupdate THEN
                            f = "Update Record Nr: " + FORMAT$(Record, "#########")
                        ELSE
                            f = "Copy Record Nr: "+ FORMAT$(Record, "#########")
                        END IF
                        CONTROL SET TEXT hdlg, %IDC_LABEL10, f
                    ELSE
                        INCR i
                        IF i > 10 THEN EXIT DO
                    END IF

                LOOP
            END IF
        END IF
    END IF


    FUNCTION = lRslt
END FUNCTION                     



Zum zweiten habe ich ein paar Funktionen z. b. Filelen diese arbeitete mit Dir$ wen die Funktion in einen anderem Programm aufgerufen wurde arbeitete sie nicht mehr korrekt deswegen arbeite ich jetzt mit der Funktion FilelenOpen die jetzt die Windows  API Funktion FindFirstFileW benutzt

Code: [Select]


FUNCTION FilelenOpen(BYVAL s AS WSTRING) AS DWORD
    LOCAL FindFileData AS WIN32_FIND_DATAW
    LOCAL hFind AS LONG
    LOCAL temp AS WSTRING
    LOCAL temp2 AS WSTRING


    hFind = FindFirstFileW(BYVAL STRPTR(s), FindFileData)

    IF BITSE(hFind, %INVALID_HANDLE_VALUE, 32) THEN
        EXIT FUNCTION
    ELSE
        FindClose(hFind)


        zsplitW s, temp, temp2

        IF temp2 = FindFileData.cFileName THEN

            FUNCTION = FindFileData.nFileSizeLow
        END IF
    END IF

END FUNCTION