我正在处理一组html文件（使用一些python代码保存在Web上的本地驱动器上），我正在查找这些文件中的关键字。然而，它们只有几页，我很难找到一种方法来使用vba自动执行以下序列：打开文件＆gt;查找关键字1＆gt;截取以keyword1为中心的屏幕截图，x宽度和y高度＆gt;在本地驱动器上以最佳格式（jpeg？）保存＆gt;转到下一个关键字＆gt;转到下一个文件。
最终目标是能够快速浏览上下文中的这些关键字。如果我设法获取这些文件，我将在Excel电子表格中使用超链接链接到这些文件。
这是我现在的代码 - 显然它不起作用：
'Get list of files in folder
Dim xRow As Long
Dim xDirect$, xFname$, InitialFoldr$
InitialFoldr$ = "blablabla"
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder to list Files from"
.InitialFileName = InitialFoldr$
If .SelectedItems.Count <> 0 Then
xDirect$ = .SelectedItems(1) & "\"
xFname$ = Dir(xDirect$, 7)
Do While xFname$ <> ""
Sheets("List of files folder").Cells(3, 2).Offset(xRow) = xFname$
xRow = xRow + 1
xFname$ = Dir
Loop
End If
End With
'Get # rows in list of files in folder
Dim myrng4 As Range
Dim lastlinelist As Integer
Dim htmlpath As String
Dim objWord
Dim objDoc
Set objWord = CreateObject("Word.Application")
Set myrng4 = Sheets("List of files folder").Range("B3:B50000")
lastlinelist = myrng4.Find(What:="*", LookIn:=xlValues, Lookat:=xlWhole, SearchOrder:=xlRows, _
SearchDirection:=xlPrevious).Row
For Each cn In Range(wb.Sheets("Results conso").Cells(3, 11), wb.Sheets("Results conso").Cells(3, Lastcolumn))
For Each fileref In Range(Sheets("List of files folder").Cells(2, 3), Sheets("List of files folder").Cells(2, lastlinelist))
With Sheets("results conso")
htmlpath = InitialFoldr$ & fileref
If Dir(htmlpath) = "" Then
Else
If LCase(Right(pdfpath, 4)) <> "html" Then
Else
Set objDoc = objWord.Documents.Open(htmlpath)
objWord.Visible = True
objDoc.BringToFront
If objDoc.findText(cn.Value, True, True, False) = False Then
objDoc.Close True
Set objDoc = Nothing
Else
Call keybd_event(VK_SNAPSHOT, 0, 0, 0)
Set objDoc = wordobj.Documents.Add
wordobj.Visible = True
Set objselection = wordobj.Selection
objselection.Paste
End If
End If
End If
End With
Next fileref
Next cn
另外，我想知道用Python而不是VBA来做这个是不是更好的主意。
非常感谢， Hadrien
答案 0 :(得分：1)
找到这个词应该很容易。我写了一个捕获屏幕截图的函数。它可能比您需要的代码更多。它正在寻找程序和窗口等。
Option Explicit
Private mblnFormActivated As Boolean
Private fsFolder As New FileSystemObject
Private fsFile As New FileSystemObject
Private bIsRealClick As Boolean
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long) 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 Const VK_MENU = &H12
Private Const VK_SNAPSHOT = &H2C
Private Const KEYEVENTF_KEYUP = &H2
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vkey As Long) As Integer
Private Sub cmdScreenshot_Click()
Dim ewohwnd As Long
Dim ewohwnd2 As Long
'This will capture a screenshot of the EWO window and save it to the job folder.
ewohwnd = GetHwndFromProcessName("EWO.EXE", "Byers View Station")
ewohwnd2 = GetHwndFromProcessName("EWO.EXE", "#32770")
If (ewohwnd2 = 0) Then
ewohwnd2 = GetHwndFromProcessName("EWO.EXE", "ICL Frame")
End If
If ewohwnd = 0 Then
MsgBox "EWO is not currently running."
Exit Sub
End If
If ewohwnd2 = 0 Then
MsgBox "validation has not been run"
Exit Sub
End If
DoEvents
If szJobFolderAlt = "" Then
Call GetWindowScreenshot(ewohwnd, ewohwnd2, szJobFolder & szJobStatus & " VALIDATION SCREENCOPY.JPG", 1)
Call ShellExecute(1, "Open", szJobFolder & szJobStatus & " VALIDATION SCREENCOPY.JPG", 0&, 0&, 10)
Else
Call GetWindowScreenshot(ewohwnd, ewohwnd2, szJobFolderAlt & szJobStatus & " VALIDATION SCREENCOPY.JPG", 1)
Call ShellExecute(1, "Open", szJobFolderAlt & szJobStatus & " VALIDATION SCREENCOPY.JPG", 0&, 0&, 10)
End If
End Sub
这是我模块中名为modWindowScreenshot
的代码Option Explicit
Private Const PIC_QUALITY_JPG = 75
Private Type GUID
data1 As Long
data2 As Integer
data3 As Integer
data4(7) As Byte
End Type
Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function Sleep Lib "Kernel32" (ByVal dwMilliseconds As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDCDest As Long, ByVal XDest As Long, ByVal YDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hDCSrc As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function BringWindowToTop Lib "user32" (ByVal hwnd As Long) As Long
Private Const GW_CHILD = 5
Private Const GW_HWNDNEXT = 2
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long
Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
'----------------------------------------------------------------------------------------------------------------------
'Section for using gdi to convert to jpeg
Private Declare Function GdiplusStartup Lib "GdiPlus.dll" (ByRef mtoken As Long, ByRef mInput As GdiplusStartupInput, ByRef mOutput As Any) As GpStatus
Private Declare Sub GdiplusShutdown Lib "GdiPlus.dll" (ByVal mtoken As Long)
Private Declare Function GdipSaveImageToFile Lib "GdiPlus.dll" (ByVal mImage As Long, ByVal mFilename As String, ByRef mClsidEncoder As gGUID, ByRef mEncoderParams As EncoderParameters) As GpStatus
Private Declare Function GdipGetEncoderParameterList Lib "GdiPlus.dll" (ByVal mImage As Long, ByRef mClsidEncoder As gGUID, ByVal msize As Long, ByRef mBuffer As EncoderParameters) As GpStatus
Private Declare Function GdipGetEncoderParameterListSize Lib "GdiPlus.dll" (ByVal mImage As Long, ByRef mClsidEncoder As gGUID, ByRef msize As Long) As GpStatus
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GdiPlus.dll" (ByVal mHbm As Long, ByVal mhPal As Long, ByRef mBitmap As Long) As GpStatus
Private Declare Function GdipDisposeImage Lib "GdiPlus.dll" (ByVal mImage As Long) As GpStatus
Private Enum GpStatus
Ok = &H0
End Enum
Private Type gGUID
Data(0 To 3) As Long
End Type
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Type EncoderParameter
GUID As gGUID
lNumberOfValues As Long
lType As Long
lValue As Long
End Type
Private Type EncoderParameters
Count As Long
Parameter(4) As EncoderParameter
End Type
Private Const EncoderParameterValueTypeLong As Long = &H4
Public Function GetWindowScreenshot(WndHandle As Long, WndHandle2 As Long, SavePath As String, Optional BringFront As Integer = 1) As Long
'
' Function to create screeenshot of specified window and store at specified path
'
On Error GoTo ErrorHandler
Dim hDCSrc As Long
Dim hDCSrc2 As Long
Dim hDCMemory As Long
Dim hDCMemory2 As Long
Dim hBmp As Long
Dim hBmp2 As Long
Dim hBmpPrev As Long
Dim hBmpPrev2 As Long
Dim WidthSrc As Long
Dim WidthSrc2 As Long
Dim HeightSrc As Long
Dim HeightSrc2 As Long
Dim Pic As PicBmp
Dim IPic As IPicture
Dim IID_IDispatch As GUID
Dim rc As RECT
Dim rc2 As RECT
'Dim pictr As PictureBox
Dim stdPic As StdPicture
'Bring window on top of all windows if specified
If BringFront = 1 Then BringWindowToTop WndHandle
BringWindowToTop WndHandle2
Sleep 50
DoEvents
'Get Window Size
GetWindowRect WndHandle, rc
WidthSrc = rc.Right - rc.Left
HeightSrc = rc.Bottom - rc.Top
'Get Window device context
hDCSrc = GetWindowDC(WndHandle)
'create a memory device context
hDCMemory = CreateCompatibleDC(hDCSrc)
'create a bitmap compatible with window hdc
hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
'copy newly created bitmap into memory device context
hBmpPrev = SelectObject(hDCMemory, hBmp)
'GET VALIDATION OVERLAY IN MEMORY
GetWindowRect WndHandle2, rc2
WidthSrc2 = rc2.Right - rc2.Left
HeightSrc2 = rc2.Bottom - rc2.Top
hDCSrc2 = GetWindowDC(WndHandle2)
hDCMemory2 = CreateCompatibleDC(hDCSrc2)
hBmp2 = CreateCompatibleBitmap(hDCSrc2, WidthSrc2, HeightSrc2)
hBmpPrev2 = SelectObject(hDCMemory2, hBmp2)
'copy window window hdc to memory hdc
Call BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, _
hDCSrc, 0, 0, vbSrcCopy)
'merg EWO and Validation messagebox
Call BitBlt(hDCMemory, (rc2.Left - rc.Left), (rc2.Top - rc.Top), WidthSrc2, HeightSrc2, _
hDCSrc2, 0, 0, vbMergeCopy)
'Get Bmp from memory Dc
hBmp = SelectObject(hDCMemory, hBmpPrev)
'release the created objects and free memory
Call DeleteDC(hDCMemory)
Call DeleteDC(hDCMemory2)
Call ReleaseDC(WndHandle, hDCSrc)
Call ReleaseDC(WndHandle2, hDCSrc2)
'fill in OLE IDispatch Interface ID
With IID_IDispatch
.data1 = &H20400
.data4(0) = &HC0
.data4(7) = &H46
End With
'fill Pic with necessary parts
With Pic
.Size = Len(Pic) 'Length of structure
.Type = vbPicTypeBitmap 'Type of Picture (bitmap)
.hBmp = hBmp 'Handle to bitmap
.hPal = 0& 'Handle to palette (may be null)
End With
'create OLE Picture object
Call OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
'return the new Picture object
'saves as bmp
'SavePicture IPic, SavePath
Set stdPic = IPic
Call saveBitmapToFileAsJPEG(stdPic, SavePath)
GetWindowScreenshot = 1
Exit Function
ErrorHandler:
GetWindowScreenshot = 0
End Function
Public Function GetHwndFromProcessName(ByVal processName As String, Optional className As String = "") As Long
On Error GoTo ErrHandler
Dim oWMI
Dim ret
Dim oServices
Dim oService
Dim servicename
Set oWMI = GetObject("winmgmts:")
Set oServices = oWMI.InstancesOf("win32_process")
'loop through all running processes for exe name
For Each oService In oServices
servicename = LCase(Trim(CStr(oService.Name) & ""))
If InStr(1, servicename, LCase(processName), vbTextCompare) > 0 Then
GetHwndFromProcessName = GetHwnd(oService.ProcessID, className)
Exit For
End If
Next
Set oServices = Nothing
Set oWMI = Nothing
ErrHandler:
Err.Clear
End Function
Private Function GetHwnd(ByVal ProcessID As Long, Optional className As String = "") As Long
Dim lHwnd As Long, RetHwnd As Long, RetPID As Long
Dim sClassName As String
Dim lMaxCount As Long
Dim lResult As Long
lMaxCount = 256
sClassName = Space(lMaxCount)
lHwnd = GetDesktopWindow()
RetHwnd = GetWindow(lHwnd, GW_CHILD)
'loop through all windows
Do While RetHwnd
If IsWindowVisible(RetHwnd) Then
If GetParent(RetHwnd) = 0 Then
'Check process id and window class name to get top window handle
'Using class name as well as process id filters out dialog windows that are not children
Call GetWindowThreadProcessId(RetHwnd, RetPID)
lResult = GetClassName(RetHwnd, sClassName, lMaxCount)
If RetPID = ProcessID Then
If className <> "" Then
If Left(sClassName, lResult) = className Then
Exit Do
End If
If Left(sClassName, 9) = className Then
Exit Do
End If
Else
Exit Do
End If
End If
End If
End If
RetHwnd = GetWindow(RetHwnd, GW_HWNDNEXT)
Loop
GetHwnd = RetHwnd
End Function
Private Function saveBitmapToFileAsJPEG(ByRef oPic As StdPicture, szImgPath As String) As Boolean
Dim hGDIPToken As Long, udtGDIPStartup As GdiplusStartupInput, udtJPEGEnc As gGUID, _
udtEncParams As EncoderParameters, hImageScrShot As Long, bRet As Boolean
' init ret value and GDI+ startup UDT
bRet = False
udtGDIPStartup.GdiplusVersion = 1
If (GdiplusStartup(hGDIPToken, udtGDIPStartup, ByVal 0) = Ok) Then
With udtJPEGEnc
' JPEG Encoder GUID: {557CF401-11D3-1A04-739A-00002EF31EF8}
.Data(0) = &H557CF401
.Data(1) = &H11D31A04
.Data(2) = &H739A
.Data(3) = &H2EF31EF8
End With
With udtEncParams
.Count = 1
With .Parameter(0)
' EncoderQuality GUID: {1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}
.GUID.Data(0) = &H1D5BE4B5
.GUID.Data(1) = &HFA4A452D
.GUID.Data(2) = &H9CDD5DB3
.GUID.Data(3) = &H5105E7EB
' The Quality Enc Param is a Long from 1(LQ) - 100(HQ)
.lType = EncoderParameterValueTypeLong
' Just this 1 "Quality" Value
.lNumberOfValues = 1
' Set Quality
'.lValue = CLng(100)
.lValue = PIC_QUALITY_JPG
End With
End With
' Create a GDIPlus Bitmap image based off the screen shot Picture
If (GdipCreateBitmapFromHBITMAP(oPic.Handle, 0, hImageScrShot) = Ok) Then
' Save it to a file and dispose of the Picture
If (GdipSaveImageToFile(hImageScrShot, StrConv(szImgPath, vbUnicode), udtJPEGEnc, udtEncParams) = Ok) Then
' File was saved to HDD
bRet = True
Set oPic = Nothing
End If
' Cleanup bitmap
Call GdipDisposeImage(hImageScrShot)
End If
' Shutdown GDI+
Call GdiplusShutdown(hGDIPToken)
End If
saveBitmapToFileAsJPEG = bRet
End Function