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

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全局代码中，运行会出现闪退，请教如何修改？

试试

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

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

然后在命令窗口试验，发现闪退在标有黄色这一句，如何修改？

'定义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

在执行 fnSaveAsEMF 这个函数过程中

ReturnValue = CopyEnhMetaFileA(GetClipboardData(CF_ENHMETAFILE), strFileName) ’进一步验证是这一句代码出了问题

运行这句代码会闪退。看看是什么原因导致的，有什么样的解决办法？

估计剪贴板没有数据，或者不是预期的格式，百度了一下，先使用IsClipboardFormatAvailable判断一下：https://www.cnblogs.com/lancidie/archive/2011/03/18/1988148.html

Public Declare Function CopyEnhMetaFileA Lib "gdi32" (ByVal hENHSrc As Long, ByVal lpszFile As String) As Long

进一步验证运行这个函数会闪退，又该如何解决呢？

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

这个我也不懂了，百度吧

主题：如何将这段vba代码改为ft可运行？