使用Adobe Acrobat Reader检索PDF数据的VBA代码 [英] VBA Code for Retrieving PDF Data with Adobe Acrobat Reader
问题描述
下面的代码是进程的一部分。该过程需要用户,行动1&操作3.动作2中的所有操作都会自动进行。 Action 3中的所有操作也会自动发生,除了CommandButton。那个:
动作1)允许用户选择PDF文件
动作2)然后打开PDF在Acrobat Reader中,从文件名中删除不良字符并重命名,复制用于将条目超链接到原始PDF的新文件路径,将PDF数据复制到隐藏的工作表中,然后另一个隐藏工作表使用Offset(Index(VLookUp (按照确切的顺序)公式从粘贴PDF数据的工作表中提取我的信息
操作3)UserForm然后允许用户在添加之前查看数据它到文档,然后用CommandButton将数据添加到文档,将文档名称超链接到原始文件,并允许用户重复该过程或关闭UserForm。
创建一个FileDialog对象作为文件选择器对话框$ b设置fd = Application.FileDialog(msoFileDialogFilePicker)作为FileDialog
$ b Dim vrtSelectedItem As Variant
Application.ScreenUpdating = False'加速宏执行
Application.DisplayAlerts = False'禁用错误消息
'Sub OPENFILE()
带有fd
'使用With ... End With块来引用FileDialog对象。
'使用Show方法显示文件选择器对话框并返回用户的操作。
'用户按动作按钮。
'On Error GoTo ErrMsg
如果.Show = -1然后
对于每个vrtSelectedItem在.SelectedItems
rc = ShellExecute(0,open,vrtSelectedItem,vbNullChar,_
vbNullChar,0)
Application.CutCopyMode = True
'等待一段时间
Application.Wait Now + TimeValue(00:00:03)'等待3秒
DoEvents
'IN ACROBAT:
'SELECT ALL
DoEvents
SendKeys^ a
'COPY
DoEvents
SendKeys^ c
'EXIT(关闭&退出)
Application.Wait Now + TimeValue(00:00:02)'等待3秒
DoEvents
SendKeys^ q
'等待一段时间
Application.Wait Now + TimeValue(00:00:06)'等待3秒
'粘贴
DoEvents
表格(Ra WAM数据)粘贴目的地:=表(原始WAM数据)范围(A1)
Sheet8.Range(a50)Value = vrtSelectedItem
Application.Wait Now + TimeValue(00:00:03)'等待3秒
'替换文件名中的错误字符并重命名文件
Dim FPath As String
Dim Ndx As Integer
Dim FName As String,strPath As String
Dim strFileName As String,strExt As String
Dim NewFileName As String
Const BadChars =@!$ /'< |> * - '把你的非法字符放在
如果Right $(vrtSelectedItem,1)<> \和Len(vrtSelectedItem)> 0然后
FilenameFromPath = GetFilenameFromPath(Left $(vrtSelectedItem,Len(vrtSelectedItem) - 1))+ Right $(vrtSelectedItem,1)
End If
FName = FilenameFromPath
对于Ndx = 1 To Len(BadChars)
FName =替换$(FName,Mid $(BadChars,Ndx,1),_)
下一个Ndx
GivenLocation = _
SRV006 \Am\Master Documents\PC 2.2.11工作文档(DFW)\DFWS添加到DFW Track \'注意尾随的反斜杠
OldFileName = vrtSelectedItem
strExt =.pdf
NewFileName = GivenLocation& FName& strExt
名称vrtSelectedItem作为NewFileName
'接下来的三行不被使用,但如果您不想重命名文件
'FPath = vrtSelectedItem'修复文件路径
'FPath =(右(FPath,Len(FPath) - I nStr(FPath,#)))
'FPath =\\& FPath
'将新文件名粘贴到要与UserForm一起使用的单元格中
Sheet8.Range(a50)= NewFileName
下一个vrtSelectedItem
Else
结束
结束
错误GoTo ErrMsg:
ErrMsg:
如果Err.Number = 1004然后
MsgBox您已取消操作'用户按下取消
退出子
结束如果
'这将分隔我的数据,所以我可以使用偏移(索引(VLookUp公式来定位在RAW表
Sheet7.Activate
Sheet7.Range(A1:A1000)。TextToColumns _
目标:= Sheet7.Range(A1:A1000)。Offset(0,0) ,_
DataType:= xlDelimited,_
Tab:= False,_
分号:= False,_
逗号:= False,_
空格:= False ,_
OTHER:= True,_
OtherChar:=:
'现在用户窗体启动时带有欲望d数据已经在TextBoxes
与UserForm2
Dim h As String
h = Sheet8.Range(A50)。值'这是我的超文本链接
UserForm2.Show
Set UserForm4 = UserForm2
On Error Resume Next
StartUpPosition = 0
.Left = Application.Left +(0.5 * Application.Width) - (0.5 *。宽度)
.Top = Application.Top +(0.5 * Application.Height) - (0.5 * .Height)
UserForm4.TextBox1.Value = Sheet8.Range(A20)
UserForm4.TextBox2.Value = Sheet8.Range(A22)
UserForm4.TextBox3.Value = Sheet8.Range(A7)
UserForm4.TextBox5.Value = Sheet8.Range( A23)
UserForm4.TextBox6.Value = Sheet8.Range(A24)
UserForm4.TextBox7.Value = Sheet8.Range(A10)
UserForm4.TextBox10.Value = Date
UserForm4.TextBox12.Value = Sheet8.Range(A34)
使用
UserForm4.TextBox17.Value = Sheet8.Range(A12)
UserForm4.TextBox14.Value = Sheet8.Range(A26)
UserForm4.TextBox17.Value = Sheet8.Range
UserForm4.TextBox19.Value = h
UserForm4.TextBox16.Value = Sheet8.Range(A18)
结束
Application.ScreenUpdating = True'刷新屏幕
End Sub
我有一个工作代码,使用Acrobat Reader获取PDF数据。它使用三张表来收集,解析和接收最终的数据。为了我的目的,我将用户窗体中收集的数据供用户查看,然后将其应用于工作表。我会发布该代码以回应这一个。
'声明API调用类型:
私有类型OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128'PSS使用的维护字符串
结束类型
'API声明:
私有声明函数GetVersionEx Libkernel32_
别名GetVersionExA_
(lpVersionInformation As OSVERSIONINFO)As Long
Private Declare Sub keybd_event Libuser32_
(ByVal bVk As Byte,_
ByVal bScan As Byte,_
ByVal dwFlags As Long,ByVal dwExtraInfo As Long)
私有声明函数GetKeyboardState Libuser32_
(pbKeyState As Byte)As Long
私有声明函数SetKeyboardState Libuser32_
(lppbKeyState As Byte)As长
'常数声明:
Const VK_NUMLOCK =& H90
Const VK_SCROLL =& H91
Const VK_CAPITAL =& H14
Const KEYEVENTF_EXTENDEDKEY =& H1
Const KEYEVENTF_KEYUP =& H2
Const VER_PLATFORM_WIN32_NT = 2
Const VER_PLATFORM_WIN32_WINDOWS = 1''私有声明子keybd_event Libuser32(_
函数ConcRange(ByRef myRange As Range,可选ByVal seperator As String =)
'用于连接粘贴在单独单元格中的PDF数据。
ConcRange = vbNullString
Dim rngCell As Range
对于每个rngCell在myRange
如果ConcRange = vbNullString然后
如果不是rngCell.Value = vbNullString然后
ConcRange = CStr(rngCell.Value)
End If
Else
如果不是rngCell.Value = vbNullString Then
ConcRange = ConcRange&分隔器CStr(rngCell.Value)
End If
End If
下一个rngCell
结束函数
函数Concat(rng As Range,可选sep As String =,) As String
'用于连接粘贴在单独单元格中的PDF数据。
Dim rngCell As Range
Dim strResult As String
对于每个rngCell在rng
如果rngCell.Value<> 然后
strResult = strResult& SEP& rngCell.Value
End If
Next rngCell
如果strResult<> 然后
strResult = Mid(strResult,Len(sep)+ 1)
End If
Concat = strResult
结束函数
函数ConcatenateRng )
'用于连接粘贴在单独单元格中的PDF数据。
Dim aAddress As Range,bAddress As Range,cRange As Range,x As String,cel As Range,rng As Range
With ActiveWorkbook
设置aAddress = Sheets(Form Input Data)。范围(I28)。值
设置bAddress =表(表单输入数据)。范围(I29)值
cResult = aAddress& bAddress
对于每个cel In rng
x = x&数值
Next
ActiveWorkbook.Sheets(Form Input Data)。Range(I35)。Text = Left(x,Len(x) - 2)
End with
结束函数
函数ConcRng(myRange,Separator)
'用于连接粘贴到单独单元格中的PDF数据。
Dim thecell As cell
FirstCell = True
设置myRangeValues = Sheets(Form Input Data)。Range(I42)。value
对于每个单元格在myRangeValues
如果FirstCell然后
ConcatenateRange = thecell
Else
如果Len(thecell)> 0然后
ConcatenateRange = ConcatenateRange&分离器thecell
Else
End If
End If
FirstCell = False
Next
结束函数
函数GetFilenameFromPath(ByVal strPath As String)As String
'返回一个字符串的最右边的字符,但不包括最右边的'\'
' 'c:\winnt\win.ini'返回'win.ini'
如果Right $(strPath,1)<> \And Len(strPath)> 0然后
GetFilenameFromPath = GetFilenameFromPath(Left $(strPath,Len(strPath) - 1))+ Right $(strPath,1)
End If
End Function
函数FileLastModified(ByVal vrtSelectedItem As String)As String
Dim fs As Object,f As Object,as As String
设置fs = CreateObject(Scripting.FileSystemObject)
设置f = fs .GetFile(vrtSelectedItem)
设置s = f.DateLastModified
's =格式(s,M / d / yyyy)
表格(表单输入数据)范围(A66 )= s
Set fs = Nothing:Set f = Nothing:Set s = Nothing
End function
函数DateLastModified(ByVal vrtSelectedItem As String)
Dim strFilename As String
'将您的文件名放在
strFilename = vrtSelectedItem
'这将创建一个MS脚本运行时的实例FileSystemObject类
设置oFS = CreateObject(Scripting FileSystemObject)
表格(Form Input Data)。范围(A65)= oFS.GetFile(strFilename).DateLastModified
设置oFS =没有
结束函数
Sub Automatic()
''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''$' $ b Dim r As Integer,c As Integer
Dim PctDone As Single
Sheets(Raw Data)。取消保护
表单(Form Input Data)。取消保护
表格(数据跟踪器).Unprotect
With Sheet10
.Unprotect
'ClearContents从RAW数据表中清除数据
调用ClearContents
结束
设置wsMaster = ThisWorkbook.Sheets(原始数据)'此工作表收集PDF数据。另一张表然后通过公式查看这张表以获取所需的信息
Dim fd As FileDialog
Dim Dt As Variant
Dim s As Range
Dim T()As String
Dim N As Long
Set s = Range(A1:A10000)
Dim hWnd
Dim StartDoc
hWnd = apiFindWindow(OPUSAPP,0)
Dim vrtSelectedItem As Variant
'Application.Visible = True'隐藏Excel文档(如果需要)
'Application.ScreenUpdating = False'加速宏执行(如果需要)
Application.DisplayAlerts = False
'创建一个FileDialog对象作为文件选择器对话框。
设置fd = Application.FileDialog(msoFileDialogFilePicker)
''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''
With fd
'使用With ... End With块引用FileDialog对象。
'使用Show方法显示文件选择器对话框并返回用户的操作。
'这里我们去...
.InitialFileName =yourfilepath'将此更改为您的文件路径,并使用特定路径,如果特定文件夹为目标
如果.Show = -1然后
'用户按动作按钮。
'''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''$ b UserForm2.Hide'这是数据结束的主要用户窗体。此过程可以从UserForm或Ribbon中调用
UserForm3.Show'此UserForm只是告诉用户该进程正在工作
与UserForm3
.StartUpPosition = 0
.Left = Application.Left +(0.5 * Application.Width) - (0.5 * .Width)
.Top = Application.Top +(0.5 * Application.Height) - (0.5 * .Height)
结束与
''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''
'切换更新加速你的代码&停止刺激的闪烁
Application.ScreenUpdating = False
对于每个vrtSelectedItem在.SelectedItems
rc = ShellExecute(0,open,vrtSelectedItem,vbNullChar,_
vbNullChar,1)
Application.CutCopyMode = True
DoEvents
'IN ACROBAT:
'SELECT ALL
Dim wbProtected As Workbook
如果应用程序.ProtectedViewWindows.Count> 0然后
设置wbProtected = Application.ProtectedViewWindows(1).Workbook
MsgBox(PROTECTED)
结束如果
Application.Wait Now + TimeValue(00:00:05 )'wait
SendKeys^ a,True'COPY
Application.Wait Now + TimeValue(00:00:03)'wait
SendKeys^ c,True'退出(关闭&退出)
Application.Wait Now + TimeValue(00:00:03)'wait
SendKeys^ q
'等待一段时间
应用程序.Wait Now + TimeValue(00:00:10)'等待10秒
错误GoTo ErrPste:
'粘贴
DoEvents
90 ActiveWorkbook.Sheets(Raw WAM数据)粘贴目标:=表(原始WAM数据)范围(A1)
''''''''''''''''''''' '''''
Dim FPath As String
Dim Ndx As Integer
Dim FName As String,strPath As String
Dim strFilename As String,strExt As String
Dim NewFileName As String
Dim OldFileName As String
Dim DLM As String
Dim FLM As String
'替换文件名中的不良字符并重命名文件
Const BadChars =@#()!$ /'< |> * - '将您的非法字符放在
如果Right $(vrtSelectedItem,1)< \和Len(vrtSelectedItem)> 0然后
FilenameFromPath = GetFilenameFromPath(Left $(vrtSelectedItem,Len(vrtSelectedItem) - 1))+ Right $(vrtSelectedItem,1)
'DLM = FileLastModified(vrtSelectedItem)
FLM = DateLastModified vrtSelectedItem)
End If
'重命名文件
FName = FilenameFromPath
对于Ndx = 1 To Len(BadChars)
FName =替换$(FName,Mid $( BadChars,Ndx,1),_)
Next Ndx
GivenLocation =yourfilepath\注意尾随的反斜杠
OldFileName = vrtSelectedItem
strExt =.pdf
NewFileName = GivenLocation& FName
'& strExt
On Error Resume Next
名称OldFileName作为NewFileName
错误GoTo ErrHndlr:
Sheet8.Range(a50)= NewFileName'将新文件名粘贴到单元格
Sheet8.Range(b65)= FLM'DateLastModfied
下一个vrtSelectedItem
Else
结束如果
结束
错误GoTo ErrMsg:
Application.ScreenUpdating = False
'''''''''''''''''''''''''''''''''''''
'为UserForm2准备PDF数据
Sheet7.Activate
Sheet7.Range(A1:A10000)。TextToColumns _
目标:= Sheet7.Range(A1: A10000)。Offset(0,0),_
DataType:= xlDelimited,_
Tab:= False,_
分号:= False,_
逗号:= False ,_
空格:= False,_
其他:= True,_
OtherChar:=:
''' ''''''''''''''''''''''''''''''''''''''
'将PDF数据复制到UserForm2
使用UserForm2
'获取超链接的文件路径
Dim L As String
Dim M As String
L = Sheet8.Range(A50)。值
M = Sheet8.Range(A60)。文本
'UserForm2.Show
Set UserForm4 = UserForm2
On Error Resume Next
StartUpPosition = 0
.Left = Application.Left +(0.5 * Application.Width) - (0.5 * .Width)
.Top = Application.Top +(0.5 * Application.Height) - (0.5 * .Height)
UserForm4.TextBox1.Value = Sheet8.Range(A20)
UserForm4.TextBox2.Value = Sheet8 .Range(A22)
UserForm4.TextBox3.Value = Sheet8.Range(A46)
UserForm4.TextBox5.Value = Sheet8.Range(A23)
UserForm4.TextBox6.Value = Sheet8.Range(A24)
UserForm4.TextBox7.Value = Sheet8.Range(A10)
UserForm4.TextBox8.Value = Sheet8.Range(A55)
UserForm4.TextBox9.Value = Sheet8.Range(A56)
如果Sheet8.Range(A58)。值=#N / A然后
UserForm4.TextBox20.Value =可选,如果名称在标题
Else
UserForm4.TextBox20.Value = Sheet8.Range(A58)。值'.Text
如果
UserForm4.TextBox10 .Value = M
UserForm4.TextBox12.Value = Sheet8.Range(A34)
UserForm4.TextBox13.Value = Sheet8.Range(A28)
UserForm4.TextBox14.Value = Sheet8.Range(A26)
UserForm4.TextBox17.Value = Sheet8.Range(A48)
UserForm4.TextBox19.Value = L
UserForm4.TextBox21.Value = Sheet8.Range (A62)
UserForm4.TextBox16.Value = Sheet8.Range(A18)
结束
'''''''''''''''''''''''b'b''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''
'错误'
''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''' ''''''''''''''
ErrPste:
'如果Err.Number = 1004然后
DoEvents
SendKeys^ a True'COPY
Application.Wait Now + TimeValue(00:00:10)'wait
SendKeys^ c,True'EXIT(Close&退出)
SendKeys^ q
'等待一段时间
Application.Wait Now + TimeValue(00:00:10)'等待10秒
'粘贴
简历90
'End If
''''''''''''''''''''''''''''' $''''''''''''''''''
ErrHndlr:
&安培; 最后修改为ON DAY& DLM
Err.Clear
简历Next
结束如果
'''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''$'$取消操作
Sheet10是我的主页,数据结束
Sheet10.Activate
退出Sub
结束如果
''''''''' '''''''''''''''''''''''''''''''''''''''''
Sheet10.Activate
Application.ScreenUpdating = True'刷新屏幕
'隐藏GetData获取您的数据UserForm
UserForm3.Hide
'显示用户可以查看数据的主用户窗体之前应用到最终的表格
UserForm2.Show
End Sub
Private Sub ClearContents ()
表(原始数据)。取消保护
表格(表单输入数据)。取消保护
带表格(原始数据)
表格(原始数据).Cells.ClearContents
End with
End Sub
The code below is a part of a process. The process requires two actions from the User,Action 1 & Action 3. All of the actions in Action 2 occur automatically. All of the actions in Action 3 also occur automatically with the exception of the CommandButton. that:
Action 1) Allows a User to select a PDF file
Action 2) Then opens the PDF in Acrobat Reader, removes bad characters from a file name and renames it, copies the new filepath which is used to hyperlink the entry to the original PDF, copies the PDF data into a hidden worksheet, then another hidden worksheet uses Offset(Index(VLookUp (in that exact order) formulas to extract my information from the worksheet where the PDF data was pasted
Action 3) A UserForm then allows the User to review the data before adding it to the document, then with a CommandButton adds the data to the document, hyperlinks the document name to the original file, and allows the User either repeat the process or close the UserForm.
Sub GetData()
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker) 'Create a FileDialog object as a File Picker dialog box
Dim vrtSelectedItem As Variant
Application.ScreenUpdating = False 'speed up macro execution
Application.DisplayAlerts = False ‘Disables error messages
'Sub OPENFILE()
With fd
'Use a With...End With block to reference the FileDialog object.
'Use the Show method to display the File Picker dialog box and return the user's action.
'The user pressed the action button.
'On Error GoTo ErrMsg
If .Show = -1 Then
For Each vrtSelectedItem In .SelectedItems
rc = ShellExecute(0, "open", vrtSelectedItem, vbNullChar, _
vbNullChar, 0)
Application.CutCopyMode = True
'Wait some time
Application.Wait Now + TimeValue("00:00:03") ' wait 3 seconds
DoEvents
'IN ACROBAT :
'SELECT ALL
DoEvents
SendKeys "^a"
'COPY
DoEvents
SendKeys "^c"
'EXIT (Close & Exit)
Application.Wait Now + TimeValue("00:00:02") ' wait 3 seconds
DoEvents
SendKeys "^q"
'Wait some time
Application.Wait Now + TimeValue("00:00:06") ' wait 3 seconds
'Paste
DoEvents
Sheets("Raw WAM Data").Paste Destination:=Sheets("Raw WAM Data").Range("A1")
Sheet8.Range("a50").Value = vrtSelectedItem
Application.Wait Now + TimeValue("00:00:03") ' wait 3 seconds
'Replace bad characters in the file name and Rename the file
Dim FPath As String
Dim Ndx As Integer
Dim FName As String, strPath As String
Dim strFileName As String, strExt As String
Dim NewFileName As String
Const BadChars = "@!$/'<|>*-—" ' put your illegal characters here
If Right$(vrtSelectedItem, 1) <> "\" And Len(vrtSelectedItem) > 0 Then
FilenameFromPath = GetFilenameFromPath(Left$(vrtSelectedItem, Len(vrtSelectedItem) - 1)) + Right$(vrtSelectedItem, 1)
End If
FName = FilenameFromPath
For Ndx = 1 To Len(BadChars)
FName = Replace$(FName, Mid$(BadChars, Ndx, 1), "_")
Next Ndx
GivenLocation = _
SRV006\Am\Master Documents\PC 2.2.11 Document For Work(DFWs)\DFWS added to DFW Track\" 'note the trailing backslash
OldFileName = vrtSelectedItem
strExt = ".pdf"
NewFileName = GivenLocation & FName & strExt
Name vrtSelectedItem As NewFileName
'The next three lines are not used but can be if you do not want to rename the file
'FPath = vrtSelectedItem 'Fixing the File Path
'FPath = (Right(FPath, Len(FPath) - InStr(FPath, "#")))
'FPath = "\\" & FPath
'pastes new file name into cell to be used with the UserForm
Sheet8.Range("a50") = NewFileName
Next vrtSelectedItem
Else
End
End With
On Error GoTo ErrMsg:
ErrMsg:
If Err.Number = 1004 Then
MsgBox "You Cancelled the Operation" ‘The User pressed cancel
Exit Sub
End If
‘This delimits my data so I can use the Offset(Index(VLookUp formulas to locate the information on the RAW sheet
Sheet7.Activate
Sheet7.Range("A1:A1000").TextToColumns _
Destination:=Sheet7.Range("A1:A1000").Offset(0, 0), _
DataType:=xlDelimited, _
Tab:=False, _
Semicolon:=False, _
Comma:=False, _
Space:=False, _
OTHER:=True, _
OtherChar:=":"
‘Now the UserForm launches with the desired data already in the TextBoxes
With UserForm2
Dim h As String
h = Sheet8.Range("A50").Value ‘This is my Hyperlink to the file
UserForm2.Show
Set UserForm4 = UserForm2
On Error Resume Next
StartUpPosition = 0
.Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
.Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)
UserForm4.TextBox1.Value = Sheet8.Range("A20")
UserForm4.TextBox2.Value = Sheet8.Range("A22")
UserForm4.TextBox3.Value = Sheet8.Range("A7")
UserForm4.TextBox5.Value = Sheet8.Range("A23")
UserForm4.TextBox6.Value = Sheet8.Range("A24")
UserForm4.TextBox7.Value = Sheet8.Range("A10")
UserForm4.TextBox10.Value = Date
UserForm4.TextBox12.Value = Sheet8.Range("A34")
UserForm4.TextBox13.Value = Sheet8.Range("A28")
UserForm4.TextBox14.Value = Sheet8.Range("A26")
UserForm4.TextBox17.Value = Sheet8.Range("A12")
UserForm4.TextBox19.Value = h
UserForm4.TextBox16.Value = Sheet8.Range("A18")
End With
Application.ScreenUpdating = True 'refreshes the screen
End Sub
I have a working code that gets the PDF data using Acrobat Reader. It uses three sheets to collect, parse, and receive the final data. For my purpose I have the data collected in a UserForm for the User to review before applying it to the sheet. I will post that code in response to this one.
' Declare Type for API call:
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128 ' Maintenance string for PSS usage
End Type
' API declarations:
Private Declare Function GetVersionEx Lib "kernel32" _
Alias "GetVersionExA" _
(lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Sub keybd_event Lib "user32" _
(ByVal bVk As Byte, _
ByVal bScan As Byte, _
ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Declare Function GetKeyboardState Lib "user32" _
(pbKeyState As Byte) As Long
Private Declare Function SetKeyboardState Lib "user32" _
(lppbKeyState As Byte) As Long
' Constant declarations:
Const VK_NUMLOCK = &H90
Const VK_SCROLL = &H91
Const VK_CAPITAL = &H14
Const KEYEVENTF_EXTENDEDKEY = &H1
Const KEYEVENTF_KEYUP = &H2
Const VER_PLATFORM_WIN32_NT = 2
Const VER_PLATFORM_WIN32_WINDOWS = 1 '''Private Declare Sub keybd_event Lib "user32" ( _
Function ConcRange(ByRef myRange As Range, Optional ByVal seperator As String = "")
'Used to Concatenate the PDF data that is pasted in separate cells.
ConcRange = vbNullString
Dim rngCell As Range
For Each rngCell In myRange
If ConcRange = vbNullString Then
If Not rngCell.Value = vbNullString Then
ConcRange = CStr(rngCell.Value)
End If
Else
If Not rngCell.Value = vbNullString Then
ConcRange = ConcRange & seperator & CStr(rngCell.Value)
End If
End If
Next rngCell
End Function
Function Concat(rng As Range, Optional sep As String = ",") As String
'Used to Concatenate the PDF data that is pasted in separate cells.
Dim rngCell As Range
Dim strResult As String
For Each rngCell In rng
If rngCell.Value <> "" Then
strResult = strResult & sep & rngCell.Value
End If
Next rngCell
If strResult <> "" Then
strResult = Mid(strResult, Len(sep) + 1)
End If
Concat = strResult
End Function
Function ConcatenateRng()
'Used to Concatenate the PDF data that is pasted in separate cells.
Dim aAddress As Range, bAddress As Range, cRange As Range, x As String, cel As Range, rng As Range
With ActiveWorkbook
Set aAddress = Sheets("Form Input Data").Range("I28").Value
Set bAddress = Sheets("Form Input Data").Range("I29").Value
cResult = aAddress & bAddress
For Each cel In rng
x = x & cel.Value & " "
Next
ActiveWorkbook.Sheets("Form Input Data").Range("I35").Text = Left(x, Len(x) - 2)
End With
End Function
Function ConcRng(myRange, Separator)
'Used to Concatenate the PDF data that is pasted in separate cells.
Dim thecell As cell
FirstCell = True
Set myRangeValues = Sheets("Form Input Data").Range("I42").Value
For Each thecell In myRangeValues
If FirstCell Then
ConcatenateRange = thecell
Else
If Len(thecell) > 0 Then
ConcatenateRange = ConcatenateRange & Separator & thecell
Else
End If
End If
FirstCell = False
Next
End Function
Function GetFilenameFromPath(ByVal strPath As String) As String
' Returns the rightmost characters of a string upto but not including the rightmost '\'
' e.g. 'c:\winnt\win.ini' returns 'win.ini'
If Right$(strPath, 1) <> "\" And Len(strPath) > 0 Then
GetFilenameFromPath = GetFilenameFromPath(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1)
End If
End Function
Function FileLastModified(ByVal vrtSelectedItem As String) As String
Dim fs As Object, f As Object, s As String
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(vrtSelectedItem)
Set s = f.DateLastModified
's = Format(s, M / d / yyyy)
Sheets("Form Input Data").Range("A66") = s
Set fs = Nothing: Set f = Nothing: Set s = Nothing
End Function
Function DateLastModified(ByVal vrtSelectedItem As String)
Dim strFilename As String
'Put your filename here
strFilename = vrtSelectedItem
'This creates an instance of the MS Scripting Runtime FileSystemObject class
Set oFS = CreateObject("Scripting.FileSystemObject")
Sheets("Form Input Data").Range("A65") = oFS.GetFile(strFilename).DateLastModified
Set oFS = Nothing
End Function
Sub Automatic()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Counter As Integer
Dim RowMax As Integer, ColMax As Integer
Dim r As Integer, c As Integer
Dim PctDone As Single
Sheets("Raw Data").Unprotect
Sheets("Form Input Data").Unprotect
Sheets("Data Tracker ").Unprotect
With Sheet10
.Unprotect
'ClearContents clears data from the RAW Data Sheet
Call ClearContents
End With
Set wsMaster = ThisWorkbook.Sheets("Raw Data") 'This sheet collects the PDF data. Another sheet then looks at this sheet via formulas to get the desired information
Dim fd As FileDialog
Dim Dt As Variant
Dim s As Range
Dim T() As String
Dim N As Long
Set s = Range("A1:A10000")
Dim hWnd
Dim StartDoc
hWnd = apiFindWindow("OPUSAPP", "0")
Dim vrtSelectedItem As Variant
'Application.Visible = True 'Hide Excel Document if desired
'Application.ScreenUpdating = False 'speed up macro execution if desired
Application.DisplayAlerts = False
'Create a FileDialog object as a File Picker dialog box.
Set fd = Application.FileDialog(msoFileDialogFilePicker)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
With fd
'Use a With...End With block to reference the FileDialog object.
'Use the Show method to display the File Picker dialog box and return the user's action.
'Here we go...
.InitialFileName = "yourfilepath" 'Change this to your file path and used a specific path if a specific folder si the target
If .Show = -1 Then
'The user pressed the action button.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
UserForm2.Hide 'This is the main UserForm where the data ends up. This process can be called from the UserForm or from the Ribbon
UserForm3.Show 'This UserForm is just telling the User that the process is working
With UserForm3
.StartUpPosition = 0
.Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
.Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)
End With
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'switch of updating to speed your code & stop irritating flickering
Application.ScreenUpdating = False
For Each vrtSelectedItem In .SelectedItems
rc = ShellExecute(0, "open", vrtSelectedItem, vbNullChar, _
vbNullChar, 1)
Application.CutCopyMode = True
DoEvents
'IN ACROBAT :
'SELECT ALL
Dim wbProtected As Workbook
If Application.ProtectedViewWindows.Count > 0 Then
Set wbProtected = Application.ProtectedViewWindows(1).Workbook
MsgBox ("PROTECTED")
End If
Application.Wait Now + TimeValue("00:00:05") ' wait
SendKeys "^a", True 'COPY
Application.Wait Now + TimeValue("00:00:03") ' wait
SendKeys "^c", True 'EXIT (Close & Exit)
Application.Wait Now + TimeValue("00:00:03") ' wait
SendKeys "^q"
'Wait some time
Application.Wait Now + TimeValue("00:00:10") ' wait 10 seconds
On Error GoTo ErrPste:
'Paste
DoEvents
90 ActiveWorkbook.Sheets("Raw WAM Data").Paste Destination:=Sheets("Raw WAM Data").Range("A1")
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim FPath As String
Dim Ndx As Integer
Dim FName As String, strPath As String
Dim strFilename As String, strExt As String
Dim NewFileName As String
Dim OldFileName As String
Dim DLM As String
Dim FLM As String
'Replace bad characters in the file name and Rename the file
Const BadChars = "@#()!$/'<|>*-—" ' put your illegal characters here
If Right$(vrtSelectedItem, 1) <> "\" And Len(vrtSelectedItem) > 0 Then
FilenameFromPath = GetFilenameFromPath(Left$(vrtSelectedItem, Len(vrtSelectedItem) - 1)) + Right$(vrtSelectedItem, 1)
'DLM = FileLastModified(vrtSelectedItem)
FLM = DateLastModified(vrtSelectedItem)
End If
'Rename the file
FName = FilenameFromPath
For Ndx = 1 To Len(BadChars)
FName = Replace$(FName, Mid$(BadChars, Ndx, 1), "_")
Next Ndx
GivenLocation = "yourfilepath\" 'note the trailing backslash
OldFileName = vrtSelectedItem
strExt = ".pdf"
NewFileName = GivenLocation & FName
'& strExt
On Error Resume Next
Name OldFileName As NewFileName
On Error GoTo ErrHndlr:
Sheet8.Range("a50") = NewFileName 'pastes new file name into cell
Sheet8.Range("b65") = FLM 'DateLastModfied
Next vrtSelectedItem
Else
End If
End With
On Error GoTo ErrMsg:
Application.ScreenUpdating = False
''''''''''''''''''''''''''''''''''''
'Prep PDF data for UserForm2
Sheet7.Activate
Sheet7.Range("A1:A10000").TextToColumns _
Destination:=Sheet7.Range("A1:A10000").Offset(0, 0), _
DataType:=xlDelimited, _
Tab:=False, _
Semicolon:=False, _
Comma:=False, _
Space:=False, _
OTHER:=True, _
OtherChar:=":"
'''''''''''''''''''''''''''''''''''''''''''''''''''
'Copy PDF Data to UserForm2
With UserForm2
'Get filepath for hyperlink
Dim L As String
Dim M As String
L = Sheet8.Range("A50").Value
M = Sheet8.Range("A60").Text
'UserForm2.Show
Set UserForm4 = UserForm2
On Error Resume Next
StartUpPosition = 0
.Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
.Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)
UserForm4.TextBox1.Value = Sheet8.Range("A20")
UserForm4.TextBox2.Value = Sheet8.Range("A22")
UserForm4.TextBox3.Value = Sheet8.Range("A46")
UserForm4.TextBox5.Value = Sheet8.Range("A23")
UserForm4.TextBox6.Value = Sheet8.Range("A24")
UserForm4.TextBox7.Value = Sheet8.Range("A10")
UserForm4.TextBox8.Value = Sheet8.Range("A55")
UserForm4.TextBox9.Value = Sheet8.Range("A56")
If Sheet8.Range("A58").Value = "#N/A" Then
UserForm4.TextBox20.Value = "Optional if Name is in Title"
Else
UserForm4.TextBox20.Value = Sheet8.Range("A58").Value '.Text
End If
UserForm4.TextBox10.Value = M
UserForm4.TextBox12.Value = Sheet8.Range("A34")
UserForm4.TextBox13.Value = Sheet8.Range("A28")
UserForm4.TextBox14.Value = Sheet8.Range("A26")
UserForm4.TextBox17.Value = Sheet8.Range("A48")
UserForm4.TextBox19.Value = L
UserForm4.TextBox21.Value = Sheet8.Range("A62")
UserForm4.TextBox16.Value = Sheet8.Range("A18")
End With
''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''
'ERRORS'
''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''
ErrPste:
'If Err.Number = 1004 Then
DoEvents
SendKeys "^a", True 'COPY
Application.Wait Now + TimeValue("00:00:10") ' wait
SendKeys "^c", True 'EXIT (Close & Exit)
SendKeys "^q"
'Wait some time
Application.Wait Now + TimeValue("00:00:10") ' wait 10 seconds
'Paste
Resume 90
'End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
ErrHndlr:
If Err.Number = 58 Then
MsgBox vrtSelectedItem & " was last modified ON DAY " & DLM
Err.Clear
Resume Next
End If
''''''''''''''''''''''''''''''''''''''''''
ErrMsg:
If Err.Number = 1004 Then
'The User stopped the process
MsgBox "You Cancelled the Operation"
'Sheet10 is my main Sheet where the data ends up
Sheet10.Activate
Exit Sub
End If
'''''''''''''''''''''''''''''''''''''''''''''''
Sheet10.Activate
Application.ScreenUpdating = True 'refreshes the screen
'Hides the "GetData is getting your data UserForm
UserForm3.Hide
'Shows the main UserForm where the User can review the data before applying it to the Final sheet
UserForm2.Show
End Sub
Private Sub ClearContents()
Sheets("Raw Data").Unprotect
Sheets("Form Input Data").Unprotect
With Sheets("Raw Data")
Sheets("Raw Data").Cells.ClearContents
End With
End Sub
这篇关于使用Adobe Acrobat Reader检索PDF数据的VBA代码的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!