有一个VB的程序也是读取PDF数据的其中的代码如下
我没弄懂，用DELPHI该怎么写?Const HKEY_CURRENT_USER = &H80000001
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
' Note that if you declare the lpData parameter as String, you must pass it By Value.
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Private Declare Function RegQueryInfoKey Lib "advapi32.dll" Alias "RegQueryInfoKeyA" (ByVal hKey As Long, ByVal lpClass As String, lpcClass As Long, ByVal lpReserved As Long, lpcSubKeys As Long, lpcMaxSubKeyLen As Long, lpcMaxClassLen As Long, lpcValues As Long, lpcMaxValueNameLen As Long, lpcMaxValueLen As Long, lpcbSecurityDescriptor As Long, lpftLastWriteTime As Long) As Long
Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcValueName As Long, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Const ChunkSize As Integer = 16384
'用api函数读取
Private Sub GetMailList_Click()
On Error GoTo quit
Dim lResult, lRootKey, lKey As Long
Dim lSubKeys As Long
Dim lValues As Long
Dim KeyName As String
Dim lKeyNameSize, lTempKeyNameSize As Long
Dim KeyValue As String
Dim lKeyValueSize, lTempKeyValueSize As Long
Dim i As Integer
Dim OEStorePath As String
Dim UserProfile As String
Dim fso As New FileSystemObject
lResult = RegOpenKey(HKEY_CURRENT_USER, "Identities", lRootKey)
If lResult = 0 Then
lResult = RegQueryInfoKey(lRootKey, 0&, 0&, 0&, 0&, 0&, 0&, lValues, lKeyNameSize, lKeyValueSize, 0&, 0&
If lResult = 0 Then
For i = 0 To lValues - 1
lTempKeyNameSize = lKeyNameSize + 1
KeyName = String(lKeyNameSize + 1, " ")
lTempKeyValueSize = lKeyValueSize + 1
KeyValue = String(lKeyValueSize + 1, " ")
lResult = RegEnumValue(lRootKey, i, KeyName, lTempKeyNameSize, 0&, 0&, KeyValue, lTempKeyValueSize)
' trim the null at the end of the returned value
If InStr(KeyName, "Default User ID") > 0 Then
Exit For
End If
Next i
End If
lResult = RegOpenKey(lRootKey, Left$(KeyValue, lTempKeyValueSize - 1) + "/Software/Microsoft/Outlook Express/5.0", lKey)
lResult = RegQueryInfoKey(lKey, 0&, 0&, 0&, 0&, 0&, 0&, lValues, lKeyNameSize, lKeyValueSize, 0&, 0&
If lResult = 0 Then
For i = 0 To lValues - 1
lTempKeyNameSize = lKeyNameSize + 1
KeyName = String(lKeyNameSize + 1, " ")
lTempKeyValueSize = lKeyValueSize + 1
KeyValue = String(lKeyValueSize + 1, " ")
lResult = RegEnumValue(lKey, i, KeyName, lTempKeyNameSize, 0&, 0&, KeyValue, lTempKeyValueSize)
' trim the null at the end of the returned value
If Left$(KeyName, lTempKeyNameSize) = "Store Root" Then
OEStorePath = Left$(KeyValue, lTempKeyValueSize - 1)
Exit For
End If
Next i
End If
End If
If Left$(OEStorePath, 1) = "%" Then
UserProfile = Environ("UserProfile")
OEStorePath = UserProfile + Mid$(OEStorePath, 14)
End If
If Right$(OEStorePath, 1) = "/" Then
fso.CopyFile OEStorePath + "收件箱.dbx", App.Path + "/收件箱.dbx"
Else
fso.CopyFile OEStorePath + "/收件箱.dbx", App.Path + "/收件箱.dbx"
End If
If fso.FileExists(App.Path + "/maillist.ini") Then
fso.DeleteFile App.Path + "/maillist.ini"
End If
'get pdf list
Shell App.Path + "/GetPDF.exe 收件箱.dbx", vbHide
Progress.Show vbModal
quit:
End Sub
Private Sub Submit_Click()
Dim i, j, k As Integer
Dim sTemp As String
Dim avDoc As Variant
Dim formApp As Variant
Dim acroForm As Variant
Dim fld As Variant
Dim FileNumber As Integer
Dim InBuf As String
Dim info() As String
Dim formName() As String
Dim FormNumber As Integer
Dim DBName() As String
Dim TempFormName As String
Dim TempDBName() As String
Dim sSQL As String
Dim ws As rdoEnvironment
Dim db As rdoConnection
Dim rs As rdoResultset
Dim TableDefs As rdoTable
Dim FieldDefs As Variant
Dim DataFile As Integer, Fl As Long, Chunks As Integer
Dim Fragment As Integer, Chunk() As Byte
'Set the mouse icon to display an hourglass
Dim Item As MSComctlLib.ListItem
i = 0
For Each Item In MailList.ListItems
If Item.Checked Then
i = i + 1
End If
Next
If i > 0 Then 'if have mailitem checked
Screen.MousePointer = 11
StoreDBProgress.Show
StoreDBProgress.DBProgressBar.Max = i
i = 0
For Each Item In MailList.ListItems
If Item.Checked Then
i = i + 1
StoreDBProgress.DBProgressBar.Value = i
FileNumber = FreeFile
'Get all keywords from type file
j = 0
Open App.Path + "/" + PDFList(Item.Index - 1) + ".type" For Input As FileNumber
Do While Not EOF(FileNumber)
Line Input #FileNumber, InBuf
InBuf = Trim(InBuf)
If InBuf <> "" Then
info = Split(InBuf, " -> ")
If info(0) = "√" Then
ReDim Preserve formName(j + 1)
ReDim Preserve DBName(j + 1)
formName(j) = info(1)
DBName(j) = info(2)
j = j + 1
End If
End If
Loop
Close #FileNumber
If j = 0 Then
MsgBox "注意，该PDF文件没有定义关键字，请重新定义！", vbExclamation, "注意"
Exit Sub
End If
'Open the PDF file
Set avDoc = CreateObject("AcroExch.AVDoc")
bOK = avDoc.Open(App.Path + "/Workspace/" + Item.SubItems(4), "")
'If everything was OK opening the PDF, we now instantiate the Forms
'Automation object.
If bOK Then
Set formApp = CreateObject("AFormAut.App")
Set acroForm = formApp.Fields
Else
Set avDoc = Nothing
MsgBox "打开PDF文件失败！", vbExclamation, "注意"
GoTo quit
End If
'Check if this pdf exists enough keywords
'FormNumber = 0
'For Each fld In acroForm
' For k = 0 To j - 1
' If fld.Name = formName(k) Then
' FormNumber = FormNumber + 1
' End If
' Next k
'Next
'It means this pdf file have enough keywords
'If FormNumber >= j Then
info = Split(DBName(j - 1), ".")
Set ws = rdoEngine.rdoEnvironments(0)
Set db = ws.OpenConnection(info(0))
Set rs = db.OpenResultset("select count(*) from " + info(1) + " where pdfname='" + Item.SubItems(4) + "'")
'MsgBox rs.rdoColumns(0).Value
If rs.rdoColumns(0).Value = 0 Then
'insert
info = Split(DBName(j - 1), ".")
'MsgBox "insert into " + Info(1) + "(pdfname) values('" + Item.SubItems(4) + "')"
'insert
db.Execute ("insert into " + info(1) + "(pdfname) values('" + Item.SubItems(4) + "')")
End If
'update
Open App.Path + "/" + PDFList(Item.Index - 1) + ".type" For Input As FileNumber
Do While Not EOF(FileNumber)
Line Input #FileNumber, InBuf
InBuf = Trim(InBuf)
If InBuf <> "" Then
info = Split(InBuf, " -> ")
If info(0) <> "√" And info(0) <> "[PDF文件名]" And info(0) <> "[PDF文件本身]" Then
TempFormName = info(0)
TempDBName = Split(info(1), ".")
sSQL = "update " + TempDBName(1) + " set " + TempDBName(2) + "="
Dim bExists As Boolean
bExists = False
For Each fld In acroForm
If fld.Name = TempFormName Then
bExists = True
'check its type
For Each TableDefs In db.rdoTables
If TempDBName(1) = TableDefs.Name Then
For Each FieldDefs In TableDefs.rdoColumns
If FieldDefs.Name = TempDBName(2) Then
'char
If FieldDefs.Type = rdTypeCHAR Or FieldDefs.Type = rdTypeVARCHAR Then
sSQL = sSQL + "'" + fld.Value + "' where pdfname='" + Item.SubItems(4) + "'"
Else 'number
If Len(fld.Value) <> 0 Then
sSQL = sSQL + fld.Value + " where pdfname='" + Item.SubItems(4) + "'"
Else
sSQL = sSQL + "0 where pdfname='" + Item.SubItems(4) + "'"
End If
End If
'exit loop
Exit For
End If
Next FieldDefs
'exit loop
Exit For
End If
Next TableDefs
'exit loop
Exit For
End If
Next
If Not bExists Then
sSQL = sSQL + "'无'"
End If
'MsgBox sSQL
'update
db.Execute (sSQL)
End If
End If
Loop
Close #FileNumber
'close the resultset
rs.Close
'process pdf filename and pdf
Open App.Path + "/" + PDFList(Item.Index - 1) + ".type" For Input As FileNumber
Do While Not EOF(FileNumber)
Line Input #FileNumber, InBuf
InBuf = Trim(InBuf)
If InBuf <> "" Then
info = Split(InBuf, " -> ")
If info(0) = "[PDF文件本身]" Then
TempDBName = Split(info(1), ".")
'the result of query
Set rs = db.OpenResultset("select * from " + TempDBName(1) + " where pdfname='" + Item.SubItems(4) + "'", rdOpenKeyset, rdConcurRowVer)
If rs.RowCount <> 0 Then
rs.Edit
DataFile = 100
Open App.Path + "/Workspace/" + Item.SubItems(4) For Binary Access Read As DataFile
Fl = LOF(DataFile) ' Length of data in file
If Fl = 0 Then Close DataFile: Exit Do
Chunks = Fl / ChunkSize
Fragment = Fl Mod ChunkSize
rs.rdoColumns(TempDBName(2)).AppendChunk Null
ReDim Chunk(Fragment)
Get DataFile, , Chunk()
rs.rdoColumns(TempDBName(2)).AppendChunk Chunk()
ReDim Chunk(ChunkSize)
For k = 1 To Chunks
Get DataFile, , Chunk()
rs.rdoColumns(TempDBName(2)).AppendChunk Chunk()
Next k
Close DataFile
rs.Update
End If
'exit loop
Exit Do
End If
End If
Loop
db.Close
ws.Close
'End If
Set avDoc = Nothing
End If
Next
Screen.MousePointer = 4
Unload StoreDBProgress
MsgBox "注意，PDF文件入库结束！", vbInformation, "注意"
End If
GoTo Ok
quit:
MsgBox "注意，入库过程出现错误，请修改文档的内容！", vbExclamation, "注意"
Screen.MousePointer = 4
Unload StoreDBProgress
Ok:
End Sub
]