查看: 6447|回复: 5
如何用VBA打开图片文件(系统中的“图片和传真查看器”)
如题：如何用VBA打开图片文件(系统中的“图片和传真查看器”)
我搜到了用第三方图片软件如ACDSEE.EXE打开图片文件，但用系统中的“图片和传真查看器”打开文件。
系统中的“图片和传真查看器”位置是C:\WINDOWS\system32\shimgvw.dll
请问如果实现我的目的
用第三方图片软件如ACDSEE.EXE打开图片文件
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column = 1 And Target.Count = 1 Then
& & If Target.Value = && Then
& && &&&Exit Sub
& && &&&Cancel = True
& && &&&Dim Ret
& && &&&jjj = ThisWorkbook.Path & &\佐证图片\& & Target.Value & &.jpg&
& && &&&Ret = Shell(ThisWorkbook.Path & &\ACDSee-v8.0_Build_39\ACDSee8.exe & & jjj, vbNormalFocus)
& & End If
(533.81 KB, 下载次数: 52)
18:05 上传
点击文件名下载附件
你的目的，是什么呢？
我的目的是在EXCEL中用系统中的系统中的“图片和传真查看器”打开文件夹中的图片文件
sPic = &D:\My Documents\1.jpg&
Shell &rundll32.exe C:\WINDOWS\system32\shimgvw.dll,ImageView_Fullscreen & & sPic, vbNormalFocus
用这个呵呵，查到了
你的目的，是什么呢？
目的是右健打开相应图片
Powered by2004年8月 其他开发语言大版内专家分月排行榜第三
2004年8月 其他开发语言大版内专家分月排行榜第三
本帖子已过去太久远了，不再提供回复功能。Access俱乐部
?&&&&?&&&&?&&&&?&&&&
您的位置：　 > >
用VBA实现截屏并保存为图片文件
来源:网络&&点击数:182&&评论数:0　&|&&|&
时　间: 16:51:23
作　者:&&&ID：252&&城市：襄樊
摘　要:通过VBA编写截屏函数，非常实用。
用VBA实现截屏并保存为图片文件：
Option Compare Database
Option Explicit
'***********************************************************************************************
' & * Please leave any Trademarks or Credits in place.
' & * ACKNOWLEDGEMENT TO CONTRIBUTORS :
' & * & & & STEPHEN BULLEN, 15 November 1998 - original PastPicture code
' & * & & & G HUDSON, 5 April 2010 - Pause Function
' & * & & & LUTZ GENTKOW, 23 July 2011 - Alt + PrtScrn
' & * & & & PAUL FRANCIS, 11 April 2013 - Putting all pieces together, bridging the 32 bit and 64 bit version.
' & * & & & CHRIS O, 12 April 2013 - Code suggestion to work on older versions of Access.
' & * DESCRIPTION: Creates a standard Picture object from whatever is on the clipboard.
' & * & & & & & & &This object is then saved to a location on the disc. Please note, this
' & * & & & & & & &can also be assigned to (for example) and Image control on a userform.
' & * The code requires a reference to the "OLE Automation" type library.
' & * The code in this module has been derived from a number of sources
' & * discovered on MSDN, Access World Forum, VBForums.
' & * To use it, just copy this module into your project, then you can use:
' & * SaveClip2Bit("C:\Pics\Sample.bmp") or &SaveClip2Bit ("D:\TEST.JPG")
' & * to save this to a location on the Disc.
' & * (Or)
' & * Set ImageControl.Image = PastePicture
' & * to paste a picture of whatever is on the clipboard into a standard image control.
' & * PROCEDURES:
' & * & PastePicture &: & The entry point for 'Setting' the Image
' & * & CreatePicture : & Private function to convert a bitmap or metafile handle to an OLE reference
' & * & fnOLEError & &: & Get the error text for an OLE error code
' & * & SaveClip2Bit &: & The entry point for 'Saving' the Image, calls for PastePicture
' & * & AltPrintScreen: & Performs the automation of Alt + PrtScrn, for getting the Active Window.
' & * & Pause & & & & : & Makes the program wait, to make sure proper screen capture takes place.
'**************************************************************************************************
'Declare a UDT to store a GUID for the IPicture OLE Interface
Private Type GUID
& & Data1 As Long
& & Data2 As Integer
& & Data3 As Integer
& & Data4(0 To 7) As Byte
'Declare a UDT to store the bitmap information
Private Type uPicDesc
& & Size As Long
& & Type As Long
& & hPic As Long
& & hPal As Long
'Windows API Function Declarations
#If Win64 = 1 And VBA7 = 1 Then
& & 'Does the clipboard contain a bitmap/metafile?
& & Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
& & 'Open the clipboard to read
& & Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
& & 'Get a pointer to the bitmap/metafile
& & Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
& & 'Close the clipboard
& & Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
& & 'Convert the handle into an OLE IPicture interface.
& & Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
& & 'Create our own copy of the metafile, so it doesn't get wiped out by subsequent clipboard updates.
& & Declare PtrSafe Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
& & 'Create our own copy of the bitmap, so it doesn't get wiped out by subsequent clipboard updates.
& & Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
& & 'Uses the Keyboard simulation
& & Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
& & 'Does the clipboard contain a bitmap/metafile?
& & Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
& & 'Open the clipboard to read
& & Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
& & 'Get a pointer to the bitmap/metafile
& & Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
& & 'Close the clipboard
& & Private Declare Function CloseClipboard Lib "user32" () As Long
& & 'Convert the handle into an OLE IPicture interface.
& & Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
& & 'Create our own copy of the metafile, so it doesn't get wiped out by subsequent clipboard updates.
& & Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
& & 'Create our own copy of the bitmap, so it doesn't get wiped out by subsequent clipboard updates.
& & Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
& & 'Uses the Keyboard simulation
& & Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
'The API format types we're interested in
Const CF_BITMAP = 2
Const CF_PALETTE = 9
Const CF_ENHMETAFILE = 14
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
Private Const KEYEVENTF_KEYUP = &H2
Private Const VK_SNAPSHOT = &H2C
Private Const VK_MENU = &H12
' Subroutine & &: AltPrintScreen
' Purpose & & & : Capture the Active window, and places on the Clipboard.
Sub AltPrintScreen()
& & keybd_event VK_MENU, 0, 0, 0
& & keybd_event VK_SNAPSHOT, 0, 0, 0
& & keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0
& & keybd_event VK_MENU, 0, KEYEVENTF_KEYUP, 0
' Subroutine & &: PastePicture
' Purpose & & & : Get a Picture object showing whatever's on the clipboard.
Function PastePicture() As IPicture
& & 'Some pointers
& & Dim h As Long, hPtr As Long, hPal As Long, lPicType As Long, hCopy As Long
& & 'Check if the clipboard contains the required format
& & If IsClipboardFormatAvailable(CF_BITMAP) Then
& & & & 'Get access to the clipboard
& & & & h = OpenClipboard(0&)
& & & & If h & 0 Then
& & & & & & 'Get a handle to the image data
& & & & & & hPtr = GetClipboardData(CF_BITMAP)
& & & & & & hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
& & & & & & 'Release the clipboard to other programs
& & & & & & h = CloseClipboard
& & & & & & 'If we got a handle to the image, convert it into a Picture object and return it
& & & & & & If hPtr && 0 Then Set PastePicture = CreatePicture(hCopy, 0, CF_BITMAP)
& & & & End If
& & End If
End Function
' Subroutine & &: CreatePicture
' Purpose & & & : Converts a image (and palette) handle into a Picture object.
' NOTE & & & & &: Requires a reference to the "OLE Automation" type library
Private Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, ByVal lPicType) As IPicture
& & ' IPicture requires a reference to "OLE Automation"
& & Dim r As Long, uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPicture
& & 'OLE Picture types
& & Const PICTYPE_BITMAP = 1
& & Const PICTYPE_ENHMETAFILE = 4
& & ' Create the Interface GUID (for the IPicture interface)
& & With IID_IDispatch
& & & & .Data1 = &H7BF80980
& & & & .Data2 = &HBF32
& & & & .Data3 = &H101A
& & & & .Data4(0) = &H8B
& & & & .Data4(1) = &HBB
& & & & .Data4(2) = &H0
& & & & .Data4(3) = &HAA
& & & & .Data4(4) = &H0
& & & & .Data4(5) = &H30
& & & & .Data4(6) = &HC
& & & & .Data4(7) = &HAB
& & End With
& & ' Fill uPicInfo with necessary parts.
& & With uPicInfo
& & & & .Size = Len(uPicInfo) ' Length of structure.
& & & & .Type = PICTYPE_BITMAP ' Type of Picture
& & & & .hPic = hPic ' Handle to image.
& & & & .hPal = hPal ' Handle to palette (if bitmap).
& & End With
& & ' Create the Picture object.
& & r = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)
& & ' If an error occurred, show the description
& & If r && 0 Then Debug.Print "Create Picture: " & fnOLEError(r)
& & ' Return the new Picture object.
& & Set CreatePicture = IPic
End Function
' Subroutine & &: fnOLEError
' Purpose & & & : Gets the message text for standard OLE errors
Private Function fnOLEError(lErrNum As Long) As String
& & 'OLECreatePictureIndirect return values
& & Const E_ABORT = &H
& & Const E_ACCESSDENIED = &H
& & Const E_FAIL = &H
& & Const E_HANDLE = &H
& & Const E_INVALIDARG = &H
& & Const E_NOINTERFACE = &H
& & Const E_NOTIMPL = &H
& & Const E_OUTOFMEMORY = &H8007000E
& & Const E_POINTER = &H
& & Const E_UNEXPECTED = &H8000FFFF
& & Const S_OK = &H0
& & Select Case lErrNum
& & & & Case E_ABORT
& & & & & & fnOLEError = " Aborted"
& & & & Case E_ACCESSDENIED
& & & & & & fnOLEError = " Access Denied"
& & & & Case E_FAIL
& & & & & & fnOLEError = " General Failure"
& & & & Case E_HANDLE
& & & & & & fnOLEError = " Bad/Missing Handle"
& & & & Case E_INVALIDARG
& & & & & & fnOLEError = " Invalid Argument"
& & & & Case E_NOINTERFACE
& & & & & & fnOLEError = " No Interface"
& & & & Case E_NOTIMPL
& & & & & & fnOLEError = " Not Implemented"
& & & & Case E_OUTOFMEMORY
& & & & & & fnOLEError = " Out of Memory"
& & & & Case E_POINTER
& & & & & & fnOLEError = " Invalid Pointer"
& & & & Case E_UNEXPECTED
& & & & & & fnOLEError = " Unknown Error"
& & & & Case S_OK
& & & & & & fnOLEError = " Success!"
& & End Select
End Function
' Routine & : SaveClip2Bit
' Purpose & : Saves Picture object to desired location.
' Arguments : Path to save the file
Public Sub SaveClip2Bit(savePath As String)
On Error GoTo errHandler:
& & AltPrintScreen
& & Pause (3)
& & SavePicture PastePicture, savePath
& & & & Exit Sub
errHandler:
& & Debug.Print "Save Picture: (" & Err.Number & ") - " & Err.Description
& & Resume errExit
' Routine & : Pause
' Purpose & : Gives a short interval for proper image capture.
' Arguments : Seconds to wait.
Public Function Pause(NumberOfSeconds As Variant)
On Error GoTo Err_Pause
& & Dim PauseTime As Variant, start As Variant
& & PauseTime = NumberOfSeconds
& & start = Timer
& & Do While Timer & start + PauseTime
& & & & DoEvents
Exit_Pause:
& & Exit Function
Err_Pause:
& & MsgBox Err.Number & " - " & Err.Description, vbCritical, "Pause()"
& & Resume Exit_Pause
End Function
　　　　　　
&&&&【&&】&&&&【&&】&&&&【&&】&&&&【&&】&&&&【&&】
Access网店
价格：￥400 元
价格：￥50 元
价格：￥100 元
(11-05 16:33)
(11-05 15:08)
(11-05 06:35)
(11-05 06:31)
(11-04 14:36)
(11-04 07:57)
(11-03 13:18)
(11-03 11:46)
(11-03 08:52)
(11-02 14:56)
Access软件网 版权所有 CopyRight
提供支持 本站特聘法律顾问: 李慧 律师查看: 2601|回复: 17
VBA 调用Mspaint，打开JPG文件
阅读权限70
在线时间 小时
VBA 调用Mspaint，打开JPG文件，而后另存
　　几千个JPG文件已经ACDSee批量处理过，规格都是150×200像素，但大小却压不下来了，很多的文件超过规定的15K。
　　用系统自带的 Mspaint 手工处理(也就是打开，再另存)后就能达到规定的要求，但比较费时，也比较麻烦，况且要处理的图片很多，因此想请高手出招。
　　现在未处理的JPG文件存放在“D:\原文件\” 的下面；经处理JPG文件存放到“D:\新文件\”的路径下。
　　请教各位如下问题：
　　① 用VBA调用Mspaint；　　
　　② 通过Mspaint打开“D:\原文件\”下的JPG文件。　　
　　③ 另存经Mspaint“压缩”后的JPG文件到“D:\新文件\”下。
　　④ 重复②~③的步骤，处理其它JPG文件。
　　请高手指点，有谢在先!
阅读权限70
在线时间 小时
& & & & & & & &
还没见高手出现。
现附两张图片，以供测试：
(22.73 KB, 下载次数: 1)
19:52 上传
(25.32 KB, 下载次数: 1)
19:51 上传
阅读权限70
在线时间 小时
遇到了双休日不成?高手们都在休息!
阅读权限100
在线时间 小时
gdi就可以保存jpg图片，你在论坛找一下代码
阅读权限70
在线时间 小时
liucqa 发表于
gdi就可以保存jpg图片，你在论坛找一下代码
谢谢你的回复。
但“gd”指的是什么啊，请明示。谢谢!
阅读权限70
在线时间 小时
俺是想用系统自带的工具，没想到系统的画图程序好像很偏门是吧？
阅读权限70
在线时间 小时
PS里的动作批处理&&不知道满足你的要求不？
阅读权限70
在线时间 小时
吾股丰登 发表于
PS里的动作批处理&&不知道满足你的要求不？
主要目的是&无损&压缩图片,因为规格150×200像素已定,能变的就文件的大小了.
PS能担此任否?
阅读权限70
在线时间 小时
“调小”JPG的文件大小& &但是尺寸不允许变了&&那应该会“有损”压缩吧？
阅读权限70
在线时间 小时
& & & & & & & &
吾股丰登 发表于
“调小”JPG的文件大小& &但是尺寸不允许变了&&那应该会“有损”压缩吧？
　　是啊，“无损”是带有引号的，肯定是要牺牲分辨率以达到规定的要求。因为是规定的，所以没得办法，只能如此。
　　请教PS如何处理？简单易学否？
最新热点 /1
ExcelHome每周都有线上直播公开课，
国内一流讲师真身分享，高手贴身答疑，
赶不上直播还能看录像，
关键居然是免费的！
厚木哥们都已经这么努力了，
你还好意思说学不好Office。
玩命加载中，请稍候
玩命加载中，请稍候
Powered by
本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！ & & 本站特聘法律顾问：徐怀玉律师 李志群律师