Poll
Question:
besteht intresse daran dann werde ich weider arbeiten
Option 1: soll ich daran bleiben
votes: 1
Option 2: soll ich es löschen
votes: 0
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
Google translation:
QuoteHave 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
QuoteSo here's the source code
Hallo
Um das Objekt in Excel oder Word zu nutzen muss folgendes Programm als Administrator ausgeführt werden
'------------------------------------------------------------------------------
'
' 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!
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.
(https://fbcdn-sphotos-d-a.akamaihd.net/hphotos-ak-prn2/t1/1897757_724939780873725_1753152029_n.jpg)
(https://fbcdn-sphotos-f-a.akamaihd.net/hphotos-ak-prn2/t1/1901274_724940617540308_38451307_n.jpg)
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.
(https://fbcdn-sphotos-h-a.akamaihd.net/hphotos-ak-prn2/t1/1601302_724975670870136_1619879324_n.jpg)
Als nächstes bitte die das Tab Entwickler Tools anwählen das erscheint das Button ,,Code Anzeigen" das müssen sie auswählen
(https://fbcdn-sphotos-b-a.akamaihd.net/hphotos-ak-ash4/t1/1656426_725356867498683_1524349734_n.jpg)
Es erscheint dann die VBA Umgebung von Excel. Bitte wählen sie hier den Menüpunkt ,,Extras" an!
(https://fbcdn-sphotos-a-a.akamaihd.net/hphotos-ak-frc3/t1/1506945_725365320831171_2107045352_n.jpg)
Hier dann den Menüpunkt Verweise auswählen.
(https://fbcdn-sphotos-g-a.akamaihd.net/hphotos-ak-ash3/t1/1904180_725397207494649_594901198_n.jpg)
Hier bitte den Verweis pbfreedb anwählen. Danach kann dann das VBA Programm geschrieben werden das das Objekt nutzt
(https://fbcdn-sphotos-f-a.akamaihd.net/hphotos-ak-prn2/t1/1780835_725400550827648_2059093858_n.jpg)
Hallo,
Wichtig ist dem Objekt die Objekt Variable zu übergeben! da diese intern für Funktionen benötigt wird
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
(https://fbcdn-sphotos-b-a.akamaihd.net/hphotos-ak-frc1/t31/1796056_730514223649614_1612521075_o.jpg)
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
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
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 ;D
(https://fbcdn-sphotos-h-a.akamaihd.net/hphotos-ak-prn2/t31/1911221_733769763324060_1650576168_o.jpg)
Dafür müssen aber die Makros in Excel für die Tabelle aktiviert werden siehe hier
(https://scontent-a-cdg.xx.fbcdn.net/hphotos-ash3/t31/1960928_733771973323839_1800550852_o.jpg)
Im nächsten Schritt muss der Makro gestartet werden.
(https://fbcdn-sphotos-c-a.akamaihd.net/hphotos-ak-frc3/t31/1798985_733772406657129_2094579241_o.jpg)
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
(https://fbcdn-sphotos-a-a.akamaihd.net/hphotos-ak-frc1/t31/1890542_733772769990426_1118713998_o.jpg)
Den Code hab ich natürlich wieder oben dazu gelegt!
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! ;)
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
(https://scontent-a-cdg.xx.fbcdn.net/hphotos-prn1/t31/1606476_734230849944618_1834445476_o.jpg)
Ergebnis wen mehrere Titel von einer CD auf Server Liegen. Habe wieder alles gepackt und am ersten Topic hinzugefügt
Grüße Peter
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
(https://scontent-a-cdg.xx.fbcdn.net/hphotos-ash3/t1/1911603_737138932987143_2070054267_n.jpg)
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.
(https://fbcdn-sphotos-b-a.akamaihd.net/hphotos-ak-ash3/t1.0-9/1959381_737136812987355_886434311_n.jpg)
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.
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
habe die Funktionen BrowseForDirectoryA und BrowseForDirectoryW umgeschrieben und durch neuen Dialog Style ersetzt schaut moderner aus und ist hundert mal schneller ;D als der alte Dialog.
'*****************************************
'** 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
(https://fbcdn-sphotos-c-a.akamaihd.net/hphotos-ak-ash3/t31/1025580_738492909518412_97466562_o)
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!
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!
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
(https://scontent-a-fra.xx.fbcdn.net/hphotos-prn2/t31.0-8/1655474_741653775868992_382219379_o.jpg)
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
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 :)
(https://fbcdn-sphotos-g-a.akamaihd.net/hphotos-ak-frc1/t31.0-8/1606441_743085692392467_165665276_o.jpg)
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.
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
(https://fbcdn-sphotos-e-a.akamaihd.net/hphotos-ak-frc1/t31.0-8/1606521_489992544456775_8668184085897105235_o.jpg)
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
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
Hab es überarbeitet für Windows 10