- Foxtable(狐表) (http://foxtable.net/bbs/index.asp)
-- 专家坐堂 (http://foxtable.net/bbs/list.asp?boardid=2)
---- ft为何闪退？ (http://foxtable.net/bbs/dispbbs.asp?boardid=2&id=161076)
-- 发布时间：2021/3/4 23:44:00
-- ft为何闪退？
全局代码有如下代码：
Public Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function CloseClipboard Lib "user32" () As Long
Public Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Public Declare Function EmptyClipboard Lib "user32" () As Long
\'// CreateMetaFileA DeleteEnhMetaFile
Public Declare Function CopyEnhMetaFileA Lib "gdi32" (ByVal hENHSrc As Long, ByVal lpszFile As String) As Long
Public Declare Function DeleteEnhMetaFile Lib "gdi32" (ByVal hemf As Long) As Long
Public Function fnSaveAsEMF(strFileName As String) As Boolean
Dim CF_ENHMETAFILE As Long = 14
Dim ReturnValue As Long
OpenClipboard(0)
ReturnValue = CopyEnhMetaFileA(GetClipboardData(CF_ENHMETAFILE), strFileName)
EmptyClipboard
CloseClipboard
\'// Release resources to it eg You can now delete it if required
\'// or write over it. This is a MUST
DeleteEnhMetaFile(ReturnValue)
fnSaveAsEMF = (ReturnValue <> 0)
End Function
命令窗口有如下代码，在桌面上建立图片文件夹，内放a.xlsx文件。执行至黄色代码处
| 下载信息 [文件大小： 下载次数： ] | |
 点击浏览该文件:管理项目7.foxdb |
出现闪退，不知何原因，请指教！
Dim App As New MSExcel.Application
App.Visible = True
Dim Wb As MSExcel.Workbook = App.WorkBooks.Open("C:\\Users\\wuyong\\Desktop\\图片\\a.xlsx")
Dim Ws As MSExcel.WorkSheet = Wb.WorkSheets(1)\'指定工作表
Dim Co As MSExcel.ChartObject = Ws.ChartObjects(1)
Dim Cht As MSExcel.Chart = Co.Chart
cht.ChartArea.Select
app.Selection.Copy
messagebox.show("01")
If fnSaveAsEMF("C:\\Users\\wuyong\\Desktop\\图片\\001.emf") Then
messagebox.show("1")
Else
messagebox.show("2")
End If
[此贴子已经被作者于2021/3/4 23:45:49编辑过]
-- 发布时间：2021/3/5 8:46:00
--
调用这句代码出错，trycatch也捕捉不到异常。这是直接调用的系统api，我也搞不懂是什么问题
ReturnValue = CopyEnhMetaFileA(GetClipboardData(CF_ENHMETAFILE), strFileName)
-- 发布时间：2021/3/5 10:23:00
--
我也知道是这句出错，所以才问为什么？查了百度也没有相关解决方案。还请大神提供解决思路。
有一个新思路，cht有这个方法，可以将图片拷到剪贴板，但如何将剪贴板上的数据再存为wmf或emf文件不会，这有什么办法吗？
经测试 cht.copypicture(2,-4117) 这句代码可以过去的。执行如下代码不会闪退，但会出现算术运算溢出的错误。请指教。
If
fnSaveAsEMF("C:\\Users\\wuyong\\Desktop\\图片\\001.emf")
Then
messagebox.show("1") Else
messagebox.show("2") End If
[此贴子已经被作者于2021/3/5 12:45:53编辑过]
-- 发布时间：2021/3/5 19:41:00
--
调用CopyEnhMetaFile函数 ansi版本CopyEnhMetaFileA会导致程序崩溃，应该调用unicode版本CopyEnhMetaFile，因为上下文都调用ansi版本，但是ft提示找不到函数CopyEnhMetaFile接口，请检查CopyEnhMetaFile函数api接口定义是否导入。
-- 发布时间：2021/3/6 8:55:00
--
试试
<UnmanagedFunctionPointer(CallingConvention.Cdecl, CharSet:=CharSet.Unicode)> _
Public Declare Function CopyEnhMetaFileA Lib "gdi32" (ByVal hENHSrc As Long, ByVal lpszFile As String) As Long-- 发布时间：2021/3/6 10:51:00
--
此主题相关图片如下：4802b9ec-4b51-4d4a-8e2d-a6304f0abeb7.png
\'全局代码------------------------------------------------------------------------------开始
<DllImport("user32.dll")>
Public Function GetClipboardData(hWndNewOwner As IntPtr) As Boolean
End Function
<DllImport("user32.dll")>
Public Function SetClipboardData(uFormat As UInteger, hMem As IntPtr) As IntPtr
End Function
<DllImport("user32.dll")>
Public Function CloseClipboard() As Boolean
End Function
<DllImport("gdi32.dll")>
Public Function CopyEnhMetaFile(hemfSrc As IntPtr, hNULL As System.Text.StringBuilder) As IntPtr
End Function
<DllImport("gdi32.dll")>
Public Function CloseEnhMetaFile(hdc As IntPtr) As Integer
End Function
<DllImport("gdi32.dll")>
Public Function DeleteEnhMetaFile(hemf As IntPtr) As IntPtr
End Function
Public Function SaveEnhMetafileToFile(mf As Metafile, fileName As String) As Boolean
Dim bResult As Boolean = False
Dim hEMF As IntPtr
hEMF = mf.GetHenhmetafile()
\' invalidates mf
If Not hEMF.Equals(New IntPtr(0)) Then
Dim tempName As New StringBuilder(fileName)
Dim hCopyEMF As IntPtr = CopyEnhMetaFile(hEMF, tempName)
DeleteEnhMetaFile(hCopyEMF)
DeleteEnhMetaFile(hEMF)
End If
Return bResult
End Function
\'全局代码------------------------------------------------------------------------------结束
\'命令窗口代码
Dim metafile As New Metafile("C:\\Users\\wuyong\\Desktop\\图片\\003.emf") ‘此行如何换成app.Selection.Copy的内容
SaveEnhMetafileToFile(metafile,"C:\\Users\\wuyong\\Desktop\\图片\\005.emf")
[此贴子已经被作者于2021/3/6 10:57:31编辑过]
-- 发布时间：2021/3/8 15:14:00
--
vba测试通过，ft不过，是不是bUg？