最近调试 VBA 实现了一个截图另存为功能。
分享一下，有类似需求的人可以少走弯路。
Sub picSaveAs()
'截图另存为图片
Dim myPic As Shape, pic As Shape
Dim rng As Range, n%
n = ActiveSheet.Shapes.Count
'设定rng=Application.InputBox(“请选择需要截取的屏幕范围：”,“截取范围”,类型:=8)
Set rng = Worksheets(“ASA”).Range(“BH2:CN110”)
rng.CopyPicture xlScreen, xlBitmap
'ActiveSheet.Paste目标位置:=ActiveSheet.Range(“A1”)
ActiveSheet.Paste Destination:=ActiveSheet.Range(“A1”)
Set myPic = ActiveSheet.Shapes(n + 1)
myPic.Copy
With ActiveSheet.ChartObjects.Add(0, 0, myPic.Width, myPic.Height).Chart
.Parent.Select
.Paste
'另存为的地址及文件名称
.Export “\192.168.1.13\化\production.JPG”
.Parent.Delete
End With
'删除 myPic
myPic.Delete
'设定myPic=空值
Set myPic = Nothing
'设定rng=空值
Set rng = Nothing
End Sub
Private Declare Sub keybd event Lib “user32” (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Sub CopyAndPaste()
Workbooks(“拷贝源文件.xlsx”).Activate
Workbooks(“拷贝源文件.xlsx”).Sheets(1).Select
Application.Wait (Now + Tim
原贴http://club.excelhome.net/thread-1193134-1-1.html
可以全屏
截图
和当前窗口
截图
Private Declare Sub keybd_event Lib "user32" _
(ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As...
'On Error Resume Next '// 发生错误，自动执行下一句，就是忽略错误
Application.ScreenUpdating = False '//关闭屏幕刷新
Application.DisplayAlerts = False '//关闭系统提示
t = Timer '//开始时间
For Eac...
On Error Resume Next '忽略错误
For n = 1 To ActiveDocument.InlineShapes.Count 'InlineShapes 类型
图片
ActiveDocument.InlineShapes(n).LockAspec.
块Module1.bas，以下程序放入标准模块内
'创建BMP位图
Public Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
Dim r As Long
Dim Pic As PicBmp
Dim IPic As IPicture
Dim IID_IDispatch As GUID
'填充IDispatch界面
With IID_IDispatch
.Data1 = &H20400; .Data4(0) = &HC0; .Data4(7) = &H46; End With
'
截图
处理
Public Function CaptureWindow(ByVal hWndSrc As Long, ByVal Client As Boolean, ByVal _
LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc _
As Long) As Picture
Dim tmpPicture As Picture
'Public Const snapFolder = "c:/Snap" '
截图
保存位置
'捕捉活动窗口
Set tmpPicture = CaptureActiveWindow()
'捕捉整个屏幕
Set tmpPicture = CaptureScreen()
SavePicture tmpPicture, "FileName完整路径名称"
VBA
实现
vlookup
功能
代码可以很简单。我们需要使用VLookup函数，它在Excel中也可用。下面是一个示例的
VBA
代码，可在指定范围内查找一个值，返回相应的结果：
Sub VLookupExample()
Dim rng As Range
Dim lookupValue As String
Dim lookupRange As Range
Dim result As Variant
Set rng = Sheet1.Range("A1:B10")
lookupValue = "AAA"
Set lookupRange = rng.Columns(1)
result = Application.VLookup(lookupValue, lookupRange, 2, False)
If IsError(result) Then
MsgBox "No match found"
MsgBox "Result is: " & result
End If
End Sub
以上代码通过在“Sheet1”工作表中的“A1:B10”区域中查找“AAA”值，并返回列B的相应值，如果找不到将返回“#N/A”错误。
代码解析：
- 设置范围变量“rng”来表示要搜索的区域。
- 设置要查找的值“lookupValue”。
- 设置查找范围变量“lookupRange”，它用来表示要在哪一列进行查找。
- 使用VLookup函数来查找相应的值。
- 判断是否返回了错误，并提供适当的消息提示。
这是一个基本的vlookup代码。可以根据需要调整变量和函数参数。此外，可以将此代码与其他Excel
VBA
代码结合使用，以创建更复杂的自动化过程。
