下面的代码是过程的一部分。该过程需要来自用户的两个动作,即动作1和动作3。动作2中的所有动作都是自动发生的。除CommandButton之外,动作3中的所有动作也会自动发生。那:
行动1)允许用户选择PDF文件
行动2)然后在Acrobat Reader中打开PDF,从文件名中删除错误字符并重命名,复制用于将条目超链接到原始PDF的新文件路径,将PDF数据复制到一个隐藏的工作表中,然后将另一个隐藏工作表使用Offset(Index(VLookUp(以确切的顺序)公式)从粘贴有PDF数据的工作表中提取我的信息
动作3)然后,用户窗体允许用户检查数据,然后再将其添加到文档中,然后使用CommandButton将数据添加到文档中,将文档名称超链接到原始文件,并允许用户重复该过程或关闭该过程用户窗体。
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
我有一个使用Acrobat Reader获取PDF数据的工作代码。它使用三张纸来收集,解析和接收最终数据。出于我的目的,我在用户表单中收集了数据,供用户检查,然后再将其应用于表格。我将针对该代码发布该代码。
' 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
本文收集自互联网,转载请注明来源。
如有侵权,请联系[email protected] 删除。
我来说两句