专家坐堂-如何将这段vba代码改为ft可运行？Foxtable(狐表) - 新一代数据库软件，完美融合Access、Foxpro、Excel、vb.net之优势，人人都能掌握的快速软件开发工具!

以文本方式查看主题

-  Foxtable(狐表)  (http://foxtable.com/bbs/index.asp)
--  专家坐堂  (http://foxtable.com/bbs/list.asp?boardid=2)
----  如何将这段vba代码改为ft可运行？  (http://foxtable.com/bbs/dispbbs.asp?boardid=2&id=159659)

--  作者：kgdce
--  发布时间：2021/1/3 22:14:00
--  如何将这段vba代码改为ft可运行？

Option Explicit
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
\'// CreateMetaFileA DeleteEnhMetaFile
Private Declare Function CopyEnhMetaFileA Lib "gdi32" (ByVal hENHSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function DeleteEnhMetaFile Lib "gdi32" (ByVal hemf As Long) As Long

Public Function fnSaveAsEMF(strFileName As String) As Boolean
Const 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

Sub SaveIt()
ActiveSheet.ChartObjects("图表 1").Activate
ActiveChart.ChartArea.Select
Selection.Copy
If fnSaveAsEMF("C:\\Users\\wuyong\\Desktop\\emf\\Excel001.emf") Then
MsgBox "Saved", vbInformation
Else
MsgBox "NOT Saved!", vbCritical
End If
End Sub
在vba上试验成功，可以将图表（chart)存为emf格式文件，但将此段代码放在ft全局代码中，运行会出现闪退，请教如何修改？

--  作者：有点蓝
--  发布时间：2021/1/3 22:31:00
--
试试

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)
return (ReturnValue <> 0)
End Function

Sub SaveIt()
ActiveSheet.ChartObjects("图表 1").Activate
ActiveChart.ChartArea.Select
Selection.Copy
If fnSaveAsEMF("C:\\Users\\wuyong\\Desktop\\emf\\Excel001.emf") Then
MsgBox( "Saved")
Else
MsgBox( "NOT Saved!")
End If
End Sub

--  作者：kgdce
--  发布时间：2021/1/3 22:55:00
--

在全局代码中如上两部分，第三部分修改在命令窗口

然后在命令窗口试验，发现闪退在标有黄色这一句，如何修改？
\'定义excel
Dim App As MSExcel.Application
Dim Wb As MSExcel.Workbook
Dim Ws As MSExcel.WorkSheet
Dim Rga As MSExcel.Range
\'在excel表中最后一行的第一个单元格生成图表
Dim rg As MSExcel.Range
dim cht as msexcel.chart
。。。。。。。（省略代码）
messagebox.show("1") \'到此是正常的
cht.ChartArea.Select
messagebox.show("2") \'到此是正常的
app.Selection.Copy
messagebox.show("3") \'到此是正常的
\'Cht.Export(projectpath & "yyt\\" & wjm &".png") \'如果用这一句也是正常的
fnSaveAsEMF(projectpath & "yyt\\" & wjm &".emf") ‘运行这一句就会闪退，请问如何能解决？
messagebox.show("4")

app.Selection.ClearContents \'清除内容
cht = Nothing

--  作者：kgdce
--  发布时间：2021/1/3 23:41:00
--

在执行 fnSaveAsEMF 这个函数过程中
ReturnValue = CopyEnhMetaFileA(GetClipboardData(CF_ENHMETAFILE), strFileName) ’进一步验证是这一句代码出了问题
运行这句代码会闪退。看看是什么原因导致的，有什么样的解决办法？

--  作者：有点蓝
--  发布时间：2021/1/4 8:47:00
--
估计剪贴板没有数据，或者不是预期的格式，百度了一下，先使用IsClipboardFormatAvailable判断一下：https://www.cnblogs.com/lancidie/archive/2011/03/18/1988148.html

--  作者：kgdce
--  发布时间：2021/1/4 10:54:00
--
Public Declare Function CopyEnhMetaFileA Lib "gdi32" (ByVal hENHSrc As Long, ByVal lpszFile As String) As Long
进一步验证运行这个函数会闪退，又该如何解决呢？

[此贴子已经被作者于2021/1/4 10:54:33编辑过]

--  作者：有点蓝
--  发布时间：2021/1/4 11:40:00
--
这个我也不懂了，百度吧