已找到原因!
是因为坐标系的缘故,在这之前一直被那个0.01毫米的精度纠结。实际上在没有设定hdc度量单位的话,默认的作图单位是像素,由于我数组里面记录的是按单位缇记录的坐标数据,我按照0.01毫米的精度转换大致是1缇=1.78(0.01毫米),所以我都乘以2了,这样定位的坐标超出屏幕外了,所以看不到。实际上还是要将缇转换为像素,即除以15才可以得到正确结果(注:PlayEnhMetaFile 设定的屏幕大小还是要按照0.01毫米精度转换),修改后的saveemf函数如下:
程序代码:
效果图:
是因为坐标系的缘故,在这之前一直被那个0.01毫米的精度纠结。实际上在没有设定hdc度量单位的话,默认的作图单位是像素,由于我数组里面记录的是按单位缇记录的坐标数据,我按照0.01毫米的精度转换大致是1缇=1.78(0.01毫米),所以我都乘以2了,这样定位的坐标超出屏幕外了,所以看不到。实际上还是要将缇转换为像素,即除以15才可以得到正确结果(注:PlayEnhMetaFile 设定的屏幕大小还是要按照0.01毫米精度转换),修改后的saveemf函数如下:
程序代码:Private Sub saveemf()
'存储图元文件
Dim hemf As Long, hpen As Long, ret As Long, lp As RECT, c As Integer, i As Integer
c = 0
For i = 0 To 100
If dxy(i, 0) = 0 And dxy(i, 1) = 0 Then Exit For
c = c + 1
Next
If c < 2 Or Trim(Text1) = "" Then
MsgBox "线段太少或文件名为空,存图失败"
Exit Sub '少于一条线段的坐标或文件名为空则不存图
End If
lp.Right = Pic1.ScaleWidth * 2
lp.Bottom = Pic1.ScaleHeight * 2 '创建图元屏幕大小仍然按照0.01毫米的单位转换乘以
lp.Top = 0
lp.Left = 0
hemf = CreateEnhMetaFile(Pic1.hdc, Text1 & ".emf", lp, vbNullString)
If hemf = 0 Then
MsgBox "图元文件创建失败"
Exit Sub
End If
hpen = CreatePen(0, 1, vbRed)
ret = SelectObject(hemf, hpen)
ret = MoveToEx(hemf, dxy(0, 0) / 15, dxy(0, 1) / 15, 0&) '作图的坐标按像素转换除以15
For i = 1 To 100
If dxy(i, 0) = 0 And dxy(i, 1) = 0 Then Exit For
ret = LineTo(hemf, dxy(i, 0) / 15, dxy(i, 1) / 15)
Next
ret = CloseEnhMetaFile(hemf)
ret = DeleteEnhMetaFile(ret)
End Sub效果图:





~
