窗体：
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, _
ByVal bScan As Byte, _
ByVal dwFlags As Long, _
ByVal dwExtraInfo As Long)
Const theScreen = 0
Const theForm = 1

Private Sub Command1_Click()
Call keybd_event(vbKeySnapshot, theForm, 0, 0)
DoEvents
Picture1.Picture = Clipboard.GetData(vbCFBitmap)
SavePic Picture1.Picture, "D:\1.gif", ".gif"
End Sub

模块：
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Type EncoderParameter
GUID As GUID
NumberOfValues As Long
type As Long
Value As Long
End Type
Private Type EncoderParameters
count As Long
Parameter As EncoderParameter
End Type

Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, _ Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, _
ByVal hPal As Long, _
BITMAP As Long) As Long
Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, _
ByVal FileName As Long, _
clsidEncoder As GUID, _
encoderParams As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal Str As Long, id As GUID) As Long
Private Declare Function CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, _
Src As Any, _
ByVal cb As Long) As Long

'*************************************************************************
'** 作 者 ： laviewpbt
'** 函 数 名 ： SavePic
'** 输 入 ： pic(StdPicture) - 图象句柄
'** ： FileName(String) - 保存路径
'** ： Quality(Byte) - JPG图象质量
'** ： TIFF_ColorDepth(Long) - TTF格式的颜色深度
'** ： TIFF_Compression(Long) - TTF格式的压缩比
'** 输 出 ： 无
'** 功能描述 ： 把图象保存为JPG、TIFF、PNG、GIF、BMP格式
'** 日 期 ： 2007.8.4
'** 修 改 人 ： BEN
'** 日 期 ： 2007.9.12
'** 修 改 人 ： XR
'** 日 期 ： 2005-10-23 14.43.52
'*************************************************************************
Public Sub SavePic(ByVal pict As StdPicture, ByVal FileName As String, PicType As String, _
Optional ByVal Quality As Byte = 80, _
Optional ByVal TIFF_ColorDepth As Long = 24, _
Optional ByVal TIFF_Compression As Long = 6)
Screen.MousePointer = vbHourglass
Dim tSI As GdiplusStartupInput
Dim lRes As Long
Dim lGDIP As Long
Dim lBitmap As Long
Dim aEncParams() As Byte
On Error GoTo ErrHandle:
tSI.GdiplusVersion = 1 ' 初始化 GDI+
lRes = GdiplusStartup(lGDIP, tSI)
If lRes = 0 Then ' 从句柄创建 GDI+ 图像
lRes = GdipCreateBitmapFromHBITMAP(pict.Handle, 0, lBitmap)
If lRes = 0 Then
Dim tJpgEncoder As GUID
Dim tParams As EncoderParameters '初始化解码器的GUID标识
Select Case PicType
Case ".jpg"
CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
tParams.count = 1 ' 设置解码器参数
With tParams.Parameter ' Quality
CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), _
.GUID ' 得到Quality参数的GUID标识
.NumberOfValues = 1
.type = 4
.Value = VarPtr(Quality)
End With
ReDim aEncParams(1 To Len(tParams))
Call CopyMemory(aEncParams(1), tParams, Len(tParams))
Case ".png"
CLSIDFromString StrPtr("{557CF406-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
ReDim aEncParams(1 To Len(tParams))
Case ".gif"
CLSIDFromString StrPtr("{557CF402-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
ReDim aEncParams(1 To Len(tParams))
Case ".tiff"
CLSIDFromString StrPtr("{557CF405-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
tParams.count = 2
ReDim aEncParams(1 To Len(tParams) + Len(tParams.Parameter))
With tParams.Parameter
.NumberOfValues = 1
.type = 4
CLSIDFromString StrPtr("{E09D739D-CCD4-44EE-8EBA-3FBF8BE4FC58}"), _
.GUID ' 得到ColorDepth参数的GUID标识
.Value = VarPtr(TIFF_Compression)
End With
Call CopyMemory(aEncParams(1), tParams, Len(tParams))
With tParams.Parameter
.NumberOfValues = 1
.type = 4
CLSIDFromString StrPtr("{66087055-AD66-4C7C-9A18-38A2310B8337}"), _
.GUID ' 得到Compression参数的GUID标识
.Value = VarPtr(TIFF_ColorDepth)
End With
Call CopyMemory(aEncParams(Len(tParams) + 1), tParams.Parameter, Len(tParams.Parameter))
Case ".bmp" '可以提前写保存为BMP的代码，因为并没有用GDI+
SavePicture pict, FileName
Screen.MousePointer = vbDefault
Exit Sub
End Select
lRes = GdipSaveImageToFile(lBitmap, StrPtr(FileName), tJpgEncoder, aEncParams(1)) '保存图像
GdipDisposeImage lBitmap ' 销毁GDI+图像
End If
GdiplusShutdown lGDIP '销毁 GDI+
End If
Screen.MousePointer = vbDefault
Erase aEncParams
Exit Sub
ErrHandle:
Screen.MousePointer = vbDefault
MsgBox "在保存图片的过程中发生错误:" & vbCrLf & vbCrLf & "错误号: " _
& err.Number & vbCrLf & "错误描述: " & err.Description, vbInformation Or vbOKOnly, "错误"
End Sub

[此贴子已经被作者于2007-9-13 9:20:04编辑过]

SavePicture 语句示例
本例使用 SavePicture 语句保存画在 Form 对象的 Picture 属性中的图形。要试用此例，可将以下代码粘贴到 Form 对象的声明部分，然后运行此例，单击 Form 对象。

Private Sub Form_Click ()
' 声明变量。
Dim CX, CY, Limit, Radius as Integer, Msg as String
ScaleMode = vbPixels ' 设置比例模型为像素。
AutoRedraw = True ' 打开 AutoRedraw。
Width = Height ' 改变宽度以便和高度匹配。
CX = ScaleWidth / 2 ' 设置 X 位置。
CY = ScaleHeight / 2 ' 设置 Y 位置。
Limit = CX ' 圆的尺寸限制。
For Radius = 0 To Limit ' 设置半径。
Circle (CX, CY), Radius, RGB(Rnd * 255, Rnd * 255, Rnd * 255)
DoEvents ' 转移到其它操作。
Next Radius
Msg = "Choose OK to save the graphics from this form "
Msg = Msg & "to a bitmap file."
MsgBox Msg
SavePicture Image, "TEST.BMP" ' 将图片保存到文件。
End Sub

1 把你画在Form的图形改为Picture
2 利用 SavePicture 比较简单.

SavePicture 语句

从对象或控件（如果有一个与其相关）的 Picture 或 Image 属性中将图形保存到文件中。

语法

SavePicture picture, stringexpression

SavePicture 语句的语法包含下面部分：

参数 描述
picture 产生图形文件的 PictureBox 控件或 Image 控件。
stringexpression 欲保存的图形文件名。

说明

无论在设计时还是运行时图形从文件加载到对象的 Picture 属性，而且它是位图、图标、元文件或增强元文件，则图形将以原始文件同样的格式保存。如果它是 GIF 或 JPEG 文件，则将保存为位图文件。

Image 属性中的图形总是以位图的格式保存而不管其原始格式。

这么多？
我本来是用printform打印form的
想向楼上请教一下是您给的程序执行快还是直接用printform执行快？

回复第三楼，试过你的程序，运行的时候会出现很多圆圈，怎么回事？

例子的内容就是出现很多圆圈，然后保存为BMP文件

试来试去还是直接打印printform速度快呀。。。。。。谢谢大家关注我的帖子