编写VB打印控制程序的几点心得
“fjbgjn”通过精心收集，向本站投稿了10篇编写VB打印控制程序的几点心得，以下是小编整理后的编写VB打印控制程序的几点心得，欢迎阅读分享。
篇1：编写VB打印控制程序的几点心得
编写VB打印控制程序的几点心得
编写VB打印控制程序的几点心得
郑州解放军信息工程大学信息安全学院计算机系（450002）
白 燕 王 鹏
摘 要本文在总结作者实际开发经验的基础上，详细介绍了VB实现高分辨率打印方法的几点心得。阐述了参数化绘图程序缩短打印程序开发时间的方法以及打印机缩放属性与窗体属性匹配使用的技巧，并总结了解决坐标定位、图形与其实际打印位置出现误差等问题的经验。
关键词PrintForm 高分辨率打印 参数化绘图 缩放属性
Some Experiences on VB Print Control
Bai Yang, Wang Peng
Computer Science Department
Universityof
Informationand Engineering
Abstract：On the basis of our working experiences, we have given a detail description about VB print method of high resolution. We focus on how to shorten developing period with parameterized plot program, the match between the zoom attribute and the attribute of display window etc., which based on print program of Printer Object. In addition to this, we have introduced some experiences on dealing with position error that caused by the mismatch between font and graph on screen and that on printer.
Keywords：PrintForm, High Resolution Print, parameterized plot ，zoom attribute
1．简介
Visual Basic（VB）给用户提供了可视化编程环境，因其简单易学、功能强大而得到了广泛的应用。VB提供了两种实现打印的方法。一般在对打印质量要求不高的场合，或者是编程项目的早期开发过程中，可以直接使用VB窗体的Printform方法实现打印。用这种方法实现打印具有编程简单、易用并且功能强大的优点，它只需要通过一行代码，几乎能打印所有内容。实现的方法就是：首先将要打印的内容在屏幕上显示出来,然后开发人员只要为窗体对象激活 PrintForm ，窗体则自动将要打印的内容发送到Printer对象上，其语法格式如下：[窗体.]PrintForm 。如果窗体中包括图形，那么打印前应先置窗体的AutoRedraw属性为真。这种方法虽然简单，但是它却存在着内存消耗大、打印粗糙、速度慢等缺陷，尤其对于带有滚动条的图像，这种方法只能打印当前可视的区域。在实际应用中经常会遇到对打印质量要求很高的场合，例如打印音乐五线谱，对打印的美观、清晰度以及音符符头的位置都有很严格的要求，这种应用场合若采用VB提供的另一种基于Printer对象的打印方法则可以获得高分辨率的打印，得到很高的打印质量。在实际应用中，也可以根据实际应用情况将上述两种方法结合起来使用，即：前期工作使用PrintForm 简单的打印方法将窗体的布局定下来，后期再使用基于Printer对象的打印方法实现最终的打印工作。
2．高分辨率打印程序开发心得
⑴ Printer对象
VB的打印可以使用Printer对象。Printer对象是一个独立于打印机设备的封装，它可以代表不同的打印机，初始时，Printer对象为系统缺省的打印机，也可以使用下列语句：Set Printer=Printers(2) (其中2代表Printers集中的第二个打印机)对打印机进行指定。
Printer对象具备例如：ColorMode、Copies、Duplex、Printquality等控制打印机特征的属性，提供了Newpage、EndDoc、KillDoc等控制打印过程的方法，以及大多数由窗体和图片框控件提供的图形属性和方法如：Currentx、Currenty、Textwidth、Textheight、Print、Pset、Line、PaintPicture和Circle等方法，它还拥有Font的所有属性。实现高分辨率的打印就是通过控制Printer对象的上述属性和方法完成的。
⑵ 直接利用Windows公用标准对话框CommonDialog控件【打印】
VB为用户提供了Windows公用标准对话框CommonDialog控件：【打开】、【文件另存为】、【颜色】、【字体】、【打印】。CommonDialog控件在Visual Basic 和Microsoft Windows动态连接库Commdlg.dll例程之间提供了接口。利用公用标准对话框【打印】开发VB的打印程序，将大大缩短程序的开发周期。应用程序中要使用公用对话框，必须首先在工具箱中添加公用对话框控件。该动作通过激活【部件】对话框，选中Microsoft Common Dialog Control6.0, 单击【确定】即可。然后再将公用控件添加到窗体上并设置相应属性，该控件具有的属性有Color、Font、Print、Help等。
VB提供mnuFilePrint_Click过程供用户添加开发的打印程序代码。
⑶ Printer对象控制打印的基本过程
利用Printer对象开发的打印程序主要靠其提供的――NewPage （打印新的一页，CurrentX、CurrentY置为新页的左上角，可完成多页功能。）、EndDoc （将打印任务加入打印机队列）、KillDoc （取消打印任务）控制打印过程的。一般情况下，打印程序完成多页打印时会多次执行NewPage，结束时执行一次EndDoc将打印任务加入打印机队列。如果你在NewPage后，立即使用EndDoc，VB则不会打印额外的空白页。如果希望显示空白页，则可在新的一页上只使用Printer.Print “ “打印空字符即可。
为了通过Printer
对象实现文本和图形的打印，获得最好的打印质量，还需要对VB控制打印机的多种属性有更深入的理解，例如打印机的坐标体系向屏幕坐标体系的转换、打印机字体尺寸的确定等。下面给出了打印程序的主框架：
Private Sub mnuFilePrint_Click
On Error Resume Next
If ActiveForm Is Nothing Then Exit Sub
With dlgCommonDialog ‘打印机公用对话框
.DialogTitle = “打印”
.CancelError = True
.Flags = 1
Printer.FontSize = dlgCommonDialog.FontSize
‘将打印机公用对话框设置的字体大小传递给打印机
.ShowPrinter ‘ 在屏幕上显示【打印】公用对话框
If Err MSComDlg.cdlCancel Then
Printer.FontTransparent = False ‘初始化打印的字体为不透明
SetPrinterScale Myform ‘匹配打印机的缩放属性与窗体的属性
PrintAnywhere Printer ‘可放置用户编写的打印对象参数化例程
‘实现字符和图形的显示
Printer.NewPage ‘打印机坐标初始化
PrintAnywhere Printer ‘打印另一页的内容
Printer.NewPage ‘打印机坐标初始化
Printer.EndDoc ‘将该任务加入打印机任务队列
‘ 不打印空白页
Printer.KillDoc ‘取消当前的打印任务
End If
End With
End Sub
⑷ 参数化绘图程序
用VB开发应用程序时，如果使用参数化绘图例程进行屏幕显示程序的开发，则在开发打印程序时，就不需再另行开发代码，从而避免了大量的重复劳动，有效地缩短了程序的开发周期。
参数化绘图例程就是：在开发例程时，为每一个例行程序提供一个OBJECT类型的参数，调用程序通过向例程的OBJECT类型参数分别传递窗体、Printer对象，就可分别完成屏幕显示与打印机输出。 见如下示例：
Sub PrintAnywhere（Dest As Object）
Dest.Print “HELLO!”
Dest Is Printer Then
Printer.EndDoc
End If
End Sub
要完成屏幕上的输出，调用 PrintAnywhere Myform 即可，而调用 PrintAnywhere Printer则完成在打印机上输出。
⑸ 属性匹配与窗体缩放
因为控制打印机实际绘图区域大小的.属性Height和Width，由目前正在使用的纸张决定，而且可打印的区域与纸张边缘有一定距离。因而为了获得正确的打印输出结果，不能简单地将Printer对象直接传递给绘图例行程序，还必须要解决打印机的缩放属性与显示窗体属性相匹配的问题。即：保证使窗体中的打印内容以正确的大小显示，并居于可打印区域的中间。实际上实现的是打印机的坐标体系向屏幕坐标体系的转换。具体过程是：使用打印机的ScaleX和ScaleY方法，获取以twip为单位的打印机尺寸，再利用窗体的ScaleX和ScaleY方法将这些尺寸转换为窗体中的坐标系统，从而实现以窗体的坐标系统提供打印机可打印区域大小的目的。然后，用这些尺寸作为打印机中新的ScaleWidth和ScaleHeight，即可实现属性匹配。
但是，我们在打印时，经常会遇到这样的场合――在不改变窗体形状的情况下，需要扩大或缩小窗体的大小。要完成这样的工作，不仅需要完成属性匹配，还要确定对象被缩放的系数。程序如下：
Private Sub SetPrinterScale(obj As Object)
Dim pwid As Single, phgt As Single, xmid As Single, ymid As Single
Dim owid As Single, ohgt As Single
owid = obj.ScaleX(obj.ScaleWidth, obj.ScaleMode, vbTwips)
ohgt = obj.ScaleY(obj.ScaleHeight, obj.ScaleMode, vbTwips)
‘获取窗体以Twips表示的尺寸
pwid = Printer.ScaleX(Printer.ScaleWidth, Printer.ScaleMode, vbTwips)
phgt = Printer.ScaleY(Printer.ScaleHeight, Printer.ScaleMode, vbTwips)
‘获取打印机以Twips表示的尺寸
If (ohgt / owid >phgt / pwid) Then
s = phgt / ohgt
Else
s = pwid / owid
End If ‘计算缩放因子
pwid = obj.ScaleX(pwid, vbTwips, obj.ScaleMode) / s
phgt = obj.ScaleY(phgt, vbTwips, obj.ScaleMode) / s
‘将打印机的尺寸转换成obj的坐标系统 / 缩放因子
x_mid = obj.ScaleLeft + obj.ScaleWidth / 2
y_mid = obj.ScaleTop + obj.ScaleHeight / 2‘设置打印区域的中心点坐标
Printer.Scale (x_mid - pwid / 2, y_mid - phgt / 2)-(x_mid + pwid / 2, y_mid + phgt / 2)
‘ 设置打印机中新的ScaleWidth和ScaleHeight
End Sub
⑹ 坐标定位
篇2：用VB实现多文档打印VB
用 VB 实现多文档打印 作者： 盛放 通常，一般情况下，我们打印文档都是直接从应用程序中打印，例如WORD，这个方法对于单个文件打印比较方便，但是对于文秘等经常需要打印大批量文件的工作人员，如果仍然用WORD一个一个进行打印就比较麻烦了， 应我公司文管
用VB实现多文档打印
作者： 盛放
通常，一般情况下，我们打印文档都是直接从应用程序中打印，例如WORD，这个方法对于单个文件打印比较方便，但是对于文秘等经常需要打印大批量文件的工作人员，如果仍然用WORD一个一个进行打印就比较麻烦了。
应我公司文管中心的要求，我制作了一个多文档打印程序，方便了文秘人员，现介绍如下：
运行VB，新建一个应用程序工程，在Form中添加一个DriveListBox 控件、DirListBox 控件和FileListBox 控件，分别取名为：Drive1、Dir1和File1。设置File1的Pattern 属性为*.doc，设置FileListBox 控件中显示的文件名为DOC文档。
在Form_Load()事件中添加一行代码：Drive1.Drive = “c:”，用来设置运行时所选择的驱动器。
在Drive1_Change()事件中添加一行代码：Dir1.Path = Drive1.Drive，这样当驱动器改变时，使目录路径随之改变。
同样在Dir1_Change()事件中添加一行代码：File1.Path = Dir1.Path，当目录改变时，使文件列表同时改变。
因为一般来说，文档都会保存在统一的目录下，所以没有使用CommonDialog 控件进行文件名选择，使操作更为简单方便。
在Form中添加一个CommandButton 控件取名为Print，用来进行打印操作。
在Command1_Click()中添加如下代码：
Dim i As Integer
Dim strfile As String
Dim word As Object
Set word = CreateObject(“word.Basic”)
word.appshow
For i = 0 To File1.ListCount - 1
If Right(Dir1.Path, 1) “” Then
strfile = Dir1.Path + “” + File1.List(i)
Else
strfile = Dir1.Path + File1.List(i)
End If
word.fileopen strfile
word.fileprint
word.fileclose
Next
word.appclose
Set word = Nothing
代码说明：
定义一个对象变量word
使用CreateObject创建一个WORD对象并赋值给word
以FileListBox 控件的列表部分项目的个数作为最大数进行循环打印
判断目录名的最后一个字母是否为“”，如果不是，则添加“”进行修正
通过目录名和文件名获得完整的文件名
使用word对象的fileopen方法打开文件
使用word对象的fileprint方法进行文件打印
使用word对象的fileclose方法关闭文件
最后调用word对象的appclose方法关闭word程序，以及释放对象资源Set word = Nothing，
这样，我们就很简单的实现了多文档的打印，希望对文秘人员有所帮助。
原文转自：www.ltesting.net
篇3：用VB编写登录程序VB
用VB编写登录程序} 》
{ 编者按：在前几期编程乐园中，我们一同学习了一些关于VB编程的基本概念和语法规则。但离开实例学习编程，无疑是枯燥无味、事倍功半的，所以我们在此推出“看实例，学编程”栏目，邀请富有经验的PFans介绍他们的典型实例，希望对PFans的编程之旅有所帮助。
我们都知道，在进入Windows操作系统时会出现一个登录对话框，要求用户输入密码后才能进入Windows。我们用VB也可以编写这样的登录窗口，其具体方法如下：
界面设计：
打开“VB6.0”，出现“新建工程”对话框，选择“标准EXE”单击“打开”即可新建一个工程。新建一个工程后，VB自动生成了一个窗体，其默认的名称是Form1，且显示的标题也是Form1，显然与我们要编写的程序不符。我们可以更改这些设置，方法是：点击Form1窗体，在右边的属性窗口中（如图1）的“名称”后输入“Denglu”（在后面讲的Denglu就是指的这个窗体），在“Caption”后输入“登录窗口”。窗体设置好后，我们便可以将控件放置到这个窗体中去了。
“登录窗口”中主要用到的是TextBox(文本框)控件，该控件主要是用于接收用户输入的文字并显示出来。在该程序中我们便可以使用TextBox控件接收用户输入的信息来判断是否是合法的用户。另外，我们还将用到Label（标签）控件及CommandButton（命令按钮）控件。Label控件用来显示“用户名”及“密码”标题；CommandButton控件用来设计“确定”及“取消”按钮。下面我们将这些控件放置到窗体中：在工具箱中选择“Label”控件（如图2），在窗体中拖动鼠标直到一定的大小，然后在属性窗口中的“Caption”属性后为输入“用户名”，然后在其下方再拖动一个Label控件，将Caption的值改为“密码：”；在工具箱中选择“TextBox”控件（如图3），在“用户名”后拖动一个TextBox控件，用同样的方法在“密码：”后拖动一个TextBox控件，然后在“属性窗口”中将Text的值改为空（即删除默认的Text1），为了不显示出用户输入的密码，我们将第二个TextBox控件的PasswordChar属性设置为＊（如图5），这样在用户输入密码时显示的就是＊了；在工具箱中选择“CommandButton”控件（如图4），将其拖动到窗体的下方（一共两个），分别设置其Caption属性为“确定”和“取消”。调整好这些控件的位置（如图6）后即可完成界面的设计，
程序代码：
该程序的主要目的是要判断输入的用户名是否合法，所以我们首先编写判断用户名的程序代码。双击“确定”按钮，添加如下的程序代码：（黑体部分为系统自动生成的代码，楷体为注释）
Private Sub Command1_Click
′判断是否输入了用户名
If Text1.Text=″″ Then ′如果Text1为空，即没有输入用户
MsgBox ″请输入用户名！″,vbOKOnly＋vbCritical,″错误″
Exit Sub ′退出这个过程
Else ′如果输入了用户名
If Text1.Text=″软件世界″ And Text2.Text=″12345″ Then ′如果输入的用户名是″软件世界″且密码为″12345″
MsgBox ″你是合法用户，欢迎进入！″,vbOKOnly＋vbInformation,″欢迎进入″
Else ′如果不是″软件世界″或密码不是″12345″
MsgBox ″用户名或密码错误！″,vbOKOnly＋vbCritical,″错误″
Text1.Text=″″
Text2.Text=″″ ′清空Text1及Text2控件中的文本内容，让用户重新输入
End If
End If
End Sub
在这一段代码中，我们使用了If…Then…Else…End If。这是一个条件判断语句，If Text1.Text=″″ Then这句代码则是判断Text1是否为空，如果为空，这个条件就成立，则执行Then后的语句，如果Text1不为空，则这个条件不成立，程序将会跳到Else处，执行Else后的语句。
程序测试：
现在我们可以单击“F5”键来运行这个程序，看看其运行效果。直接单击“确定”按钮，将会弹出一个对话框（如图7）；在“用户名”后输入“软件世界”，“密码：”后输入“12345”，再单击“确定”按钮，此时便会出现一个“欢迎进行”的信息框（如图8）。怎么样，一个属于自己的“登录窗口”就制作好了。
但这个程序目前还只能判断在程序中已设置好了的用户名及密码，没有灵活性，你可以发挥你的聪明才智，使其能够判断多个合法的用户及密码。如果你有什么疑问，欢迎写信与我交流，我的E－mail地址是：vber@21cn.com。
（重庆 杜伟）}
原文转自：www.ltesting.net
篇4：用VB编写投注程序VB
时下全国各地都在搞“电脑型福利彩票”，相信很多读者朋友都参与过或正准备参与吧，笔者也是一个“彩民”，已为中国福利事业贡献了XXX元了，不过好像运气不怎么好，至今连个末等奖也未中到，在投注时，彩号可以自己在投注单上选，也可以通过投注机随机选
时下全国各地都在搞“电脑型福利彩票”，相信很多读者朋友都参与过或正准备参与吧，笔者也是一个“彩民”，已为中国福利事业贡献了XXX元了，不过好像运气不怎么好，至今连个末等奖也未中到。在投注时，彩号可以自己在投注单上选，也可以通过投注机随机选取。那么，想不想自己编个程序来模拟“机选”呢？好！那就接着往下看吧！
首先，新建一个单窗体的工程，在上面画出七个TEXTBOX，最好是一个控件数组，这样编程时容易控制，再建一个COMMOND BUTTON，将CAPTION改为“随机产生”。在程序运行后，每点击一下COMMAND1，将随机产生一组数字并按从小到大的顺序显示在文本框中。下面就是程序部分：
Dim NumArray(1 To 7) As Integer′通用中定义
Private Sub Command1_Click()
Dim i, j, N As Integer
For i = 1 To 7
NumArray(i) = 0
Next i
Randomize
NumArray(1) = Fix(1 ＋ 32 ＊ (Rnd()))
j = 1
Do
N = Fix(1 ＋ 32 ＊ (Rnd()))
For i = 1 To j
If N = NumArray(i) Then
Exit For ′重复时
ElseIf i = j Then ′未重复时
NumArray(i ＋ 1) = N
j = j ＋ 1
Exit For
End If
Next i
Loop While j < 7
PopSort ′升序排列
For i = 1 To 7
Text1(i － 1).Text = NumArray(i)
Next i
End Sub
Private Sub PopSort() ′气泡排序法
Dim i, j, Temp As Integer
For i = 7 To 2 Step －1
For j = 7 － 1 To 1 Step －1
If i >= 7 － j ＋ 1 Then
If NumArray(j ＋ 1) < NumArray(j) Then
Temp = NumArray(j)
NumArray(j) = NumArray(j ＋ 1)
NumArray(j ＋ 1) = Temp
End If
End If
Next j
Next i
End Sub
本程序在VB6.0中文企业版、Win98SE中文版下调试通过，
为了简捷起见，这个程序还有很多不尽如人意的地方，比如不能保存等，喜欢编程的朋友可以充分发挥自己的聪明才智对其加以扩充。
原文转自：www.ltesting.net
篇5：VB是如何编写病毒的
相信电脑界的每个人都痛恨计算机病毒，她给我们带来了很多麻烦和损失，可你知道编写病毒的方法和过程吗？在此我仅以VB编写为例，揭开她的面纱，
VB是如何编写病毒的
，
用VB编写病毒需要考虑到如下几点： 感染主机 首先染毒文件运行后先要判断主机是否以感染病毒，也就是判断病毒主
篇6：VB程序设计心得
VB程序设计心得
在课程设计过程中，虽然我对程序设计不是很熟悉，但是通过老师详细的讲解，我按照步骤去做，遇到问题的时候先自己想办法解决，解决不了的就去问同学，问老师，通过这种学习，收获很大，学会了自己解决棘手问题，知道了团结的力量。刚开始做程序的时候，就是完全按照老师的要求，老师的步骤去做的，结果却发现，怎么运行不了？明明是按照老师的步骤去做的，明明是按照老师的要求去做的，但是就是会遇到一些问题使程序运行不了。开始也没有管那么多，仍然是按照课本上的去做。
第一次，在上机课的时候，我根据老师讲的，在机房里做了一次，但没有做完。于是把东西存在了自己的MP3里面，以便以后上机的时候再来做。但真的没有想到，我的MP3，在一次上电子阅览室的时候，忘了拔了。于是乎，我辛辛苦苦做了一大节课的程序就这样没了。心里真的.很不舒服，但是，不舒服归不舒服，这个程序，还是得继续做下去，这么以点点小小的失误不算什么，然后跑到学校机房，继续我的VB程序设计。但由于时间问题，做的还是有点粗糙，还是不免存在一定的问题，比如说开始的时候打开不了文件，总是出现错误，自己总也找不出来，后来请教了一下同学，结果发现时代码的编写出现了错误，把代码改过来之后，程序终于可以打开运行了。然后，检查的时候，又发现“查找”运行错误，又是代码那里出现的黄色的字样，结果发现，是代码拼写错误，于是，拿着同学的代码对比一下，发现了错误所在之地，然后更正了过来。
经过一番努力，程序终于做完了。
您现在阅览的是工作总结网-心得体会wWw.GzzONGjie.Cn/xdth/谢谢您的支持和鼓励！
后来，室友看了我的程序，她说运行不了的，就是出现了错误，出现了错误，就应该改过啊，这时的我才恍然大悟。“是错误，那么就要改正的！”于是当天，我就去了学校机房，再一次运行我的程序，仍然出现错误情况，需要调试，我回忆起上课的时候，老师是怎么跟我们讲的，哪里出现了错误，需要怎么样改正。于是，我就耐着性子，一个一个，一个一个得改正，编辑代码，一个一个得检查，终于完成了。完成之后，我在运行一下，一切正常，心里终于舒了一口气。经过这次的VB程序设计，让我知道了更多学习的方法。具体如下：(1)保持良好的学习心态，第一，要有自信，自强，积极主动学习.第二，克服畏难情绪，树立学好程序设计的信心(2)要了解概念：VB程序设计本身并不复杂，变量，函数，条件语句，循环语句等概念较多.要真正能进行程序设计，就要深入理解这些概念.应该重视概念的学习.
(3)自己动手编写程序，亲自动手进行程序设计是培养逻辑思维的好方法.因此我们得多动手编写程序，逐渐提高写程序的能力.自己动手，编写一些程序，才会有成就感，进而对课程产生兴趣，做起来才比较从容.等你在编写大量程序之后（4）上机调试程序应注意多问问同学，多问问老师、，把不懂的地方标出来。(5)养成良好的编程习惯，第一，程序构思要有说明;第二，学会如何调试程序;第三，对运行结果要做正确与否的分析。
但是，如果以前上课的时候不认真的听讲的话，做这个程序设计就会有点点困难，所以，同时也在提醒我们，学习，任何时候都要认真！
总之，在此次的VB程序设计中，如果没有足够的耐心，就不可能完成的很好。所以此次VB程序设计，让我做事情更加有耐心，更加细心，学习更加认真仔细。 相关专题：尚无数据
篇7：用printer对象打印表格VB
用printer对象打印表格 用 msf lexgrid控件显示的表格，要将它打印出来，最简单的方法是用printform方法，然而这只适合于数据正好能被屏幕显示的，即数据量少的，而且这种打印效果很差，而用printer对象进行打印编程，虽然麻烦点，但效果却是相当不错的，你
用printer对象打印表格
用msflexgrid控件显示的表格，要将它打印出来，最简单的方法是用printform方法，然而这只适合于数据正好能被屏幕显示的，即数据量少的，而且这种打印效果很差。而用printer对象进行打印编程，虽然麻烦点，但效果却是相当不错的，你可以自定义打印格式，打印页数，表格的粗细，字体大小等。实际上用printer对象进行打印编程是比较简单的。
下面我就用一实例来说明:
打印的内容是一张数据表，这里就只有两列数据，包括标题，副标题。(用A4纸打印)
假设数据处在C_DataArray,和R_DataArray()中C_Name与R_Name分别为两数据项的字段名
Public Sub Printtable()
注释：初始化
Dim printer1 as Printer
Dim pageheader
Dim pagefooter
Dim pageleft
Dim pageright
Dim usewidth
Dim useheight
Dim i, j, k As Integer
Dim word As String
Dim startx
Dim starty
Dim startyline ‘ 用来纪录打印竖线的起点
Dim endyline ’ 用来纪录打印竖线的末点
设置页面参数
pageheader = 25
pagefooter = 25
pageleft = 20
pageright = 20
With printer1
.PaperSize = 9
.ScaleMode = 6
.FontBold = True
.ScaleLeft = -20
.ScaleTop = -25
.ScaleWidth = 210 注释：设置为A4纸
.ScaleHeight = 297
usewidth = .ScaleWidth - 40
useheight = .ScaleHeight - 50
.CurrentX = 0
.CurrentY = 0
.DrawWidth = 5
End With
注释：打印标题
With printer1
.FontSize = 20
.CurrentX = (usewidth - .TextWidth(DataTitle)) / 2
.CurrentY = pageheader + .ScaleTop
End With
printer1.Print DataTitle
注释：打印副标题
printer1.FontSize = 15
word = DataTitle2
printer1.CurrentX = usewidth - printer1.TextWidth(word)
printer1.Print word
注释：打印第一条线 Line方法不能用在with ....end with里
printer1.CurrentX = pageleft + printer1.ScaleLeft
startyline = printer1.CurrentY
注释：线宽
printer1.Line -((printer1.ScaleLeft + printer1.ScaleWidth - pageleft), printer1.CurrentY)
printer1.FontSize = 10
注释：printer1.PrintvbLf
printer1.CurrentY = printer1.CurrentY + 1
注释：打印第一个字段名
starty = printer1.CurrentY
printer1.CurrentX = ((printer1.ScaleWidth - 40) / 2 - printer1.TextWidth(C_Name)) / 2
printer1.Print C_Name
注释：打印第二个字段名
printer1.CurrentX = usewidth / 2 + ((usewidth / 2 - printer1.TextWidth(R_Name)) / 2)
printer1.CurrentY = starty
printer1.Print R_Name
printer1.CurrentY = printer1.CurrentY + 1
注释：打印数据和横线,rownum为数据行数
For i = 1 To rownum
注释：判断是否该页已打满
If printer1.CurrentY >= useheight Then
注释：打印横线
printer1.CurrentX = printer1.ScaleLeft + pageleft
printer1.Line -((printer1.ScaleLeft + printer1.ScaleWidth - pageleft), printer1.CurrentY)
printer1.CurrentY = printer1.CurrentY + 1
注释：打印三条竖线
endyline = printer1.CurrentY
printer1.Line (0, startyline)-(0, endyline)
printer1.Line (usewidth / 2, startyline)-(usewidth / 2, endyline)
printer1.Line (usewidth, startyline)-(usewidth, endyline)
注释：打印页号
With printer1
.CurrentX = (.ScaleWidth - .TextWidth(.Page)) / 2 - pageleft
.CurrentY = useheight + 3
End With
printer1.Print printer1.Page
printer1.NewPage
With printer1
.CurrentX = pageleft + .ScaleLeft
.CurrentY = pageheader + .ScaleTop
startyline = .CurrentY
End With
End If
注释：打印一行数据
printer1.CurrentX = ((printer1.ScaleWidth - 40) / 2 - printer1.TextWidth(C_DataArray(i))) / 2
starty = printer1.CurrentY
printer1.Print C_DataArray(i)
printer1.CurrentX = (printer1.ScaleWidth - 40) / 2 + ((printer1.ScaleWidth - 40) / 2 - printer1.TextWidth(R_DataArray(i) )) / 2
printer1.CurrentY = starty
printer1.Print R_DataArray(i)
printer1.CurrentY = printer1.CurrentY + 1
Next i
注释：打印最后一条横线
printer1.CurrentX = printer1.ScaleLeft + pageleft
printer1.Line -((printer1.ScaleLeft + printer1.ScaleWidth - pageleft), printer1.CurrentY)
endyline = printer1.CurrentY
注释：打印三条竖线
printer1.Line (0, startyline)-(0, endyline)
printer1.Line (usewidth / 2, startyline)-(usewidth / 2, endyline)
printer1.Line (usewidth, startyline)-(usewidth, endyline)
注释：打印页号
With printer1
.CurrentX = (.ScaleWidth - .TextWidth(.Page)) / 2 - pageleft
.CurrentY = useheight + 3
End With
printer1.Print printer1.Page
printer1.EndDoc
end sub
原文转自：www.ltesting.net
篇8：用VB编写DirectX7.0游戏(二)VB
建立一个新的工程文件，点击菜单中的 Project | Reference 选项，打开Object Library 列表窗口，将DirectX 7.0 For Visual Basic Type Library 加入工程文件，将Form1的Name属性改变为MainForm，在MainForm中加入一个PictureBox控件，将其的Visible属性设置
建立一个新的工程文件，点击菜单中的 Project | Reference 选项，打开Object Library 列表窗口，将DirectX 7.0 For Visual Basic Type Library 加入工程文件。将Form1的Name属性改变为MainForm，在MainForm中加入一个PictureBox控件，将其的Visible属性设置为False。然后在MainForm的代码窗口中加入以下代码：
Private Sub Form_KeyPress(KeyAscii As Integer)
Dim sRect As RECT
Dim hdcSrc As Long
If KeyAscii = 27 Then
ExitLoop = True
注释：End
ElseIf KeyAscii =vbKeyReturn Then
DDSFront.BltToDC Picture1.hDC, sRect, sRect
With Picture1
注释：获得与主显示平面兼容的图形设备句柄
hdcSrc = DDSFront.GetDC
注释：保存图像
Set .Picture = SaveTohBmp(hdcSrc, 0, 0, 640, 480)
注释：释放图形句柄
DDSFront.ReleaseDC hdcSrc
SavePicture Picture1, “c:a.bmp”
End With
End If
End Sub
Public Sub Form_Paint()
BlitRect.Right = DDSBackDesc.lWidth
BlitRect.Bottom = DDSBackDesc.lHeight
DDSFront.Blt BlitRect, DDSBack, BlitRect, DDBLT_WAIT
End Sub
在工程文件中加入一个Module文件，这个文件中DirectDraw操作做出了定义，在这个Module中加入以下代码：
Option Explicit
Public DX As New DirectX7
Public DDraw As DirectDraw7
Public DDSFront As DirectDrawSurface7
Public DDSFrontDesc As DDSURFACEDESC2
Public DDSBack As DirectDrawSurface7
Public DDSBackDesc As DDSURFACEDESC2
Public Clipper As DirectDrawClipper
Dim Pict() As Byte
Dim AlphaRect As RECT
Dim X As Long, Y As Long
Dim Temp As Long
Dim Index As Long
Dim Index2 As Long
Dim Pos As Long
Dim PosPlus1 As Long
Dim PosPlus2 As Long
Dim PosPlus3 As Long
Public Pal(255) As PALETTEENTRY
Public Palette As DirectDrawPalette
Public BlitRect As RECT
Public FullSize As Boolean
Public ExitLoop As Boolean
Dim Aclearcase/“ target=”_blank“ >ccum As Long
Dim Msg(9) As String
Dim Counter As Long
Dim MsgIndex As Long
Dim bDrawText As Boolean
Dim lastTime As Long
DimXPos As Long, YPos As Long
Dim wait As Long
Dim Angle As Single
Dim Flag As Boolean
Dim Count As Long
Dim CurModeActiveStatus As Boolean
Dim bRestore As Boolean
Dim Mode As Boolean
Private Sub Main()
InitializeDX
注释：初始化Picture1以获得DirectDraw界面图像
With MainForm.Picture1 .Width = 640 ＊ Screen.TwipsPerPixelX .Height = 480 ＊ Screen.TwipsPerPixelY
End With
DDSBack.SetForeColor RGB(255, 255, 255)
MainForm.Font.Name = “宋体”
DDSBack.SetFont MainForm.Font
Msg(0) =“一个显示火焰字的演示”
Msg(1) =“演示”
Msg(2) =“利用VB阵列”
Msg(3) =“对显示内存”
Msg(4) =“进行直接存取”
Msg(5) =“键退出”
注释：设置8位的调色板
For Index = 0 To 84
Pal(Index ＋ 1).red = Index ＊ 3 ＋ 3
Pal(Index ＋ 1).green = 0
Pal(Index ＋ 1).blue = 0
Pal(Index ＋ 86).red = 255
Pal(Index ＋ 86).green = Index ＊ 3 ＋ 3
Pal(Index ＋ 86).blue = 0
Pal(Index ＋ 171).red = 255
Pal(Index ＋ 171).green = 255
Pal(Index ＋ 171).blue = Index ＊ 3 ＋ 3
Next
Set Palette = DDraw.CreatePalette(DDPCAPS_8BIT _ Or DDPCAPS_ALLOW256, Pal())
DDSFront.SetPalette Palette
AlphaRect.Right = DDSBackDesc.lWidth － 1
AlphaRect.Bottom=DDSBackDesc.lHeight－ 1
DDSBack.Lock AlphaRect, DDSBackDesc, DDLOCK_WAIT, 0
DDSBack.GetLockedArray Pict()
For X = 0 To 639
For Y = 0 To 479
Pict(X, Y) = 0
Next
Next
注释：Corresponding unlock
DDSBack.Unlock AlphaRect
While Not ExitLoop
Mode = ExModeActive
bRestore = False
Do Until ExModeActive
DoEvents
bRestore = True
Loop
DoEvents
If bRestore Then
bRestore = False
DDraw.RestoreAllSurfaces
End If
DDSBack.Lock AlphaRect, DDSBackDesc, DDLOCK_WAIT, 0
DDSBack.GetLockedArray Pict()
For Y = 0 To 479
Pict(0, Y) = 0
Pict(639, Y) = 0
Next
For X = 0 To 639
Pict(X, 477) = Rnd ＊ 220 ＋ 35
Pict(X, 478) = Rnd ＊ 220 ＋ 35
Pict(X, 479) = Rnd ＊ 220 ＋ 35
Next
Accum = 0
For X = 1 To 638
For Y = 0 To 477
Accum = (Accum ＋ Pict(X, Y ＋ 1) _
＋ Pict(X, Y ＋ 2) _
＋ Pict(X ＋ 1, Y ＋ 1) _
＋ Pict(X － 1, Y ＋ 1)) 5
If Accum < 0 Then
Accum = 0
ElseIf Accum >255 Then
Accum = 255
End If
Pict(X, Y) = Accum
Next
Next
For X = 0 To 639
Pict(X, 0) = 0
Pict(X, 1) = 0
Next
X = Rnd ＊ 639
For Y = 50 To 439
Next
DDSBack.Unlock AlphaRect
If DX.TickCount() － lastTime >wait Then
If Counter = 0 Then
bDrawText = True
Counter = 1
XPos = Rnd ＊ 200
YPos = 300 ＋ Rnd ＊ 140
wait = 400
ElseIf Counter = 1 Then
MsgIndex = MsgIndex ＋ 1
If MsgIndex >5 Then MsgIndex = 0
bDrawText = False
Counter = 0
wait =
End If
lastTime = DX.TickCount
End If
If bDrawText Then
On Error Resume Next
DDSBack.DrawText XPos, YPos, Msg(MsgIndex), False
On Error GoTo 0
End If
MainForm.Form_Paint
Wend
TerminateDX
End
End Sub
Function ExModeActive() As Boolean
Dim TestCoopRes As Long
TestCoopRes = DDraw.TestCooperativeLevel
Select Case TestCoopRes
Case DDERR_NOEXCLUSIVEMODE
ExModeActive = False
Case DD_OK
ExModeActive = True
End Select
End Function
Public Sub InitializeDX()
MainForm.Left = 0
MainForm.Top = 0
MainForm.Height =640 ＊ Screen.TwipsPerPixelY
MainForm.Width = 480 ＊ Screen.TwipsPerPixelX
MainForm.Show
注释：建立DirectDraw对象
Set DDraw = DX.DirectDrawCreate(“”)
注释：设定DirectDraw对象的协作层
DDraw.SetCooperativeLevel MainForm.hWnd, DDSCL_EXCLUSIVE Or DDSCL_FULLSCREEN 注释： DDSCL_NORMAL
注释：设定显示模式位640×480×8位颜色
DDraw.SetDisplayMode 640, 480, 8, 0, DDSDM_DEFAULT
注释：设定DDSFrontDesc为主平面
With DDSFrontDesc
.lFlags = DDSD_CAPS
.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE 注释：Or DDSCAPS_SYSTEMMEMORY
End With
注释：设定DDSBackDesc为后台缓冲平面
With DDSBackDesc
.ddsCaps.lCaps = DDSCAPS_SYSTEMMEMORY
.lFlags = DDSD_CAPS Or DDSD_WIDTH Or DDSD_HEIGHT
.lWidth = 640
.lHeight = 480
End With
注释：建立平面
Set DDSFront = DDraw.CreateSurface(DDSFrontDesc)
Set DDSBack = DDraw.CreateSurface(DDSBackDesc)
Set Clipper = DDraw.CreateClipper(0)
Clipper.SetHWnd MainForm.hWnd
DDSFront.SetClipper Clipper
DDSBack.SetClipper Clipper
DoEvents
Exit Sub
ERRoUT:
If Not (DDraw Is Nothing) Then
DDraw.RestoreDisplayMode
DDraw.SetCooperativeLevel MainForm.hWnd, DDSCL_NORMAL
DoEvents
End If
MsgBox “无法对DirectDraw进行初始化 ”＋Chr(13)＋“也许你的显示卡不支持 640×480×8 显示模式 ”
End
End Sub
Public Sub TerminateDX()
注释：子程序TerminateDX回复原来的显示模式并且释放所有的DirectDraw有关对象
DDraw.RestoreDisplayMode
DDraw.SetCooperativeLevel MainForm.hWnd, DDSCL_NORMAL
DoEvents
Set Clipper = Nothing
Set DDSBack = Nothing
Set DDSFront = Nothing
Set DDraw = Nothing
Set DX = Nothing
End Sub
在工程文件中再加入一个Module，这个Module主要定义与图像保存相关的操作，在建立的Module中加入以下代码：
Option Explicit
Option Base 0
Private Type PALETTEENTRY
peRed As Byte
peGreen As Byte
peBlue As Byte
peFlags As Byte
End Type
Private Type LOGPALETTE
palVersion As Integer
palNumEntries As Integer
palPalEntry(255) As PALETTEENTRY
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Const RASTERCAPS As Long = 38
Private Const RC_PALETTE As Long = ＆H100
Private Const SIZEPALETTE As Long = 104
Private Declare Function CreateCompatibleDC Lib “GDI32” (ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib “GDI32” (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function GetDeviceCaps Lib “GDI32” (ByVal hDC As Long, ByVal iCapabilitiy As Long) As Long
Private Declare Function GetSystemPaletteEntries Lib “GDI32” (ByVal hDC As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
Private Declare Function CreatePalette Lib “GDI32”(lpLogPalette As LOGPALETTE) As Long
Private Declare Function SelectObject Lib “GDI32”(ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib “GDI32”(ByVal hDCDest As Long, ByVal XDest As Long, ByVal YDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hdcSrc As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) As Long
Private Declare Function DeleteDC Lib “GDI32”(ByVal hDC As Long) As Long
Private Declare Function GetForegroundWindow Lib “USER32” () As Long
Private Declare Function SelectPalette Lib “GDI32”(ByVal hDC As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
Private Declare Function RealizePalette Lib “GDI32” (ByVal hDC As Long) As Long
Private Declare Function GetWindowDC Lib “USER32” (ByVal hWnd As Long) As Long
Private Declare Function GetDC Lib “USER32”(ByVal hWnd As Long) As Long
Private Declare Function GetWindowRect Lib “USER32”(ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function ReleaseDC Lib “USER32”(ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function GetDesktopWindow Lib “{USER32“() As Long
Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type
Private Declare Function OleCreatePictureIndirect Lib “olepro32.dll” (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Public Function SaveTohBmp(ByVal hdcSrc As Long, ByVal LeftSrc As Long, _
ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture
Dim hDCMemory As Long
Dim hBmp As Long
Dim hBmpPrev As Long
Dim r As Long
Dim hPal As Long
Dim hPalPrev As Long
Dim RasterCapsScrn As Long
Dim HasPaletteScrn As Long
Dim PaletteSizeScrn As Long
Dim LogPal As LOOGPALETTE
注释：建立一个内存图形设备句柄
hDCMemory=CreateCompatibleDC(hdcSrc)
注释：建立一个bitmap并保存到hDCMemory中
hBmp = CreateCompatibleBitmap(hdcSrc, WidthSrc, HeightSrc)
hBmpPrev = SelectObject(hDCMemory, hBmp)
RasterCapsScrn = GetDeviceCaps(hdcSrc, RASTE图CAPS) 注释：rRaste
HasPaletteScrn = RasterCapsScrn And RC_PALtTTEic1 注释： Palette
PaletteSizeScrn = GetDeviceCaps(hdcSrc, SIZEPALETTE) 注释： Size of
If HasPaletteScrn And (PaletteSizeScrn = 256) Then
注释：建立系统调色板的拷贝
LogPal.palVersion = ＆H300
LogPal.palNumEntries = 256
r = GetSystemPaletteEntries(hdcSrc, 0, 256, LogPal.palPalEntry(0))
hPal = CreatePalette(LogPal)
hPalPrev = SelectPalette(hDCMemory, hPal, 0)
r = RealizePalette(hDCMemory)
End If
注释：将屏幕图形拷贝到内存图形设备句柄中
r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hdcSrc, LeftSrc, TopSrc, vbSrcCopy)
hBmp = SelectObject(hDCMemory, hBmpPrev)
If HasPaletteScrn And (PaletteSizeScrn = 256) Then
hPal = SelectPalette(hDCMemory, hPalPrev, 0)
End If
注释：释放图形设备句柄
r = DeleteDC(hDCMemory)
Debug.Print r
注释：调用CreateBitmapPicture函数从指定的bitmap对象和调色板中建立一个picture对象
Set SaveTohBmp = CreateBitmapPicture(hBmp, hPal)
End Function
Public Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
Dim r As Long
Dim Pic As PicBmp
Dim IPic As IPicture
Dim IID_IDispatch As GUID
注释：填充IDispatch界面
With IID_IDispatch
.Data1 = ＆H20400
.Data4(0) = ＆HC0
.Data4(7) = ＆H46
End With
注释：填充Pic结构
With Pic
.Size = Len(Pic) 注释： Length of structure.
.Type = vbPicTypeBitmap 注释： Type of Picture (bitmap).
.hBmp = hBmp 注释： Handle to bitmap.
.hPal = hPal 注释： Handle to palette (may be null).
End With
注释：建立Picture对象
r = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
注释：返回Picture对象
Set CreateBitmapPicture = IPic
End Function
运行程序，在屏幕上会出现一些火焰字的特效，按Enter键可以将屏幕保存到“c:a.bmp”中，按Esc键退出程序回到Windows，
在上面的程序中，程序首先建立一个DirectDraw对象，然后设置该对象的协作层为全屏协作模式，接下来设置显示模式为640×480×8位颜色，建立一个前台DirectDrawSurface对象和一个后台缓冲DirectDrawSurface对象，建立和设置DirectDrawClipper对象。
在主程序段中，程序首先对前台绘图平面的调色板（DirectDrawPalette）对象进行操作以改变显示的文字的颜色，然后对后台缓冲绘图平面进行字节操作，以产生文字弥散的效果，然后再将后台缓冲绘图平面翻转到前台。当用户按下Enter键之后，程序获得与前台绘图平面相兼容的图形设备句柄，然后再调用Windows API函数将绘图平面内存中的内容保存到Windows位图文件中。
上面粗略地介绍了DirectX7 SDK的新特性以及初步的DirectDraw编程，希望对大家能有所帮助。以上的程序在Windows98、VB6.0下运行通过。
原文转自：www.ltesting.net
篇9：用VB编写Flash图像浏览器VB
flash编写的动画，可惜的是只能在线观看，若下载下来则必须安装Flash 才能观看，可是Flash 对于只想观看动画来说未必太大了吧，那么有没有可能自己制作一个Flash图像浏览器？当然可以，请跟我来。 首先需要安装Flash控件Swflash.ocx。 您可以通过“控制面板
flash编写的动画，可惜的是只能在线观看，若下载下来则必须安装Flash 才能观看。可是Flash 对于只想观看动画来说未必太大了吧，那么有没有可能自己制作一个Flash图像浏览器？当然可以，请跟我来。
首先需要安装Flash控件Swflash.ocx。 您可以通过“控制面板”―“添加/删除程序”进行安装。选择“Windows安装程序”页，在“多媒体”中选择“详细资料”，将“Macromedia Shockwave Flash”前的复选项选中，将Windows 98光盘放入光驱，点击“确定”即可将控件安装注册。
让我们再来看看控件Swflash.ocx的基本属性：
属性
取值及说明
Loop True：允许循环播放
False：不允许循环播放
Menu True：允许显示右键快捷菜单
False：不允许显示右键快捷菜单
Movie 所要播放的动画文件的路径和文件名
Playing True：播放
False：停止
Quality 0：低分辨率( 即Quality2：Low)
1：高分辨率( 即Quality2：High)
2：自动降低分辨率 ( 即Quality2：AutoLow)
3：自动升高分辨率( 即Quality2：AutoHigh)
Quality2 见上，和Quality变化一致
ScaleMode 0：全部显示(即Scale：Showall)
1：无边界(即Scale：NoBorder)
2：自动适应控件大小(即Scale：ExactFit)
Scale 见上，和ScaleMode变化一致
编程：
1．打开VB，新建工程，在“控件”工具箱空白处单击右键，在快捷菜单中选择“添加控件”，在控件列表中选中“Shockware sh”复选框，按“确定”即可将Swflash.ocx控件添加到“控件” 工具箱。 2．按照图1位置在Form1中添加若干控件，其属性如下表：
控件类型 控件名称 属性 值
CommandButtom cmdPlay Caption 播放
cmdStop Caption 停止
cmdback
Caption 上一帧
cmdForward
Caption
下一帧
Shockwareflash ShockwaveFlash1 Loop
Menu
Playing
Quality
ScaleMode True
True
Flase
1
2
lblFileName Caption 空白的
DriveListBox Drive1
PathListBox Path1
FileListBox File1 Pattern *.swf
3．将驱动器，目录和文件列表框建立联系
Private Sub Dir1_Change
File1.Path = Dir1
End Sub
Private Sub Drive1_Change()
Dir1.Path = Drive1
End Sub
4．当鼠标选中某个swf文件的时候，动画立即放映
Private Sub File1_Click()
‘ 设置按钮和Swflash.ocx控件的状态
cmdStop.Enabled = True
cmdBack.Enabled = True
cmdForward.Enabled = True
ShockwaveFlash1.Visible = True
ShockwaveFlash1.Playing = True
ShockwaveFlash1.Movie = File1.Path + ”“ + File1
lblFilename.Caption = ”当前放映的动画是“ + File1.Path + ”“ + File1
End Sub
5．编写按钮的事件
‘ 上一帧
Private Sub cmdBack_Click()
ShockwaveFlash1.Back
End Sub
‘ 下一帧
Private Sub cmdForward_Click()
ShockwaveFlash1.Forward
End Sub
‘ 播放
Private Sub cmdPlay_Click()
ShockwaveFlash1.Play
cmdPlay.Enabled = False
cmdStop.Enabled = True
End Sub
‘ 停止
Private Sub cmdStop_Click()
ShockwaveFlash1.Stop
cmdStop.Enabled = False
cmdPlay.Enabled = True
End Sub
6．编写 点击E-mail 地址的电子邮件调用
‘申明API函数
Declare Function ShellExecute Lib ”shell32.dll“ Alias ”ShellExecuteA“ (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
‘ 调用电子邮件
Private Sub lblRight_Click()
ShellExecute 0&,vbNullString, ”mailto:mralways@fm365.com“, vbNullString, vbNullString, vbNormalFocus
End Sub
这样，经过编译为执行文件，一个简单又实用的Flash 图像浏览器就做成功了，
您可以到中国软件程序员大本营(www.csdn.net/cnshare/softview.asp?id=3248)或硅谷动力下载区(www.esoftware.com.cn/filebrhoto/see/2000102301.shtml)去下载我的作品。
网上的Flash动画资源有：
网易 Flash 站：flash.163.com/
Flash 图库：www.china-contact.com/flash/
天极网 网页陶吧之Flash站：desktop.yesky.com/home/flash.htm
有些网页上根本就不提供动画的下载功能，您可以单击右键，打开快捷菜单中的“查看源码”，用“查找”功能查找“.swf”文字，找到的文件路径即可用工具进行下载了。
原文转自：www.ltesting.net
篇10：用VB编写DDraw程序初步VB
用 VB 编写DDraw程序初步 DirectX7.0终于出现了，同前面DirectX6相同，版本7也带了一个庞大（129M）的SDK 开发 库，同DirectX6 SDK库相比，DirectX7的SDK库提供了以下新的功能 l 对于Visual Basic的支持，用户可以使用类库在Visual Basic环境下开发基于Direc
用VB编写DDraw程序初步
DirectX7.0终于出现了，同前面DirectX6相同，版本7也带了一个庞大（129M）的SDK开发库，同DirectX6 SDK库相比，DirectX7的SDK库提供了以下新的功能
l 对于Visual Basic的支持。用户可以使用类库在Visual Basic环境下开发基于DirectX的程序。
l 提供更多DirectX3D立即模式（Immediate Mode）下API函数，以支持DirectX7中新的3D特效，包括立体环境映射、顶点混合等。
l DirectMusic支持DownLoadable Sound Level 2标准。
l DirectInput支持8按键的游戏杆设备，同时支持Microsoft的力反馈摇杆。SDK库提供了读取力反馈效果文件的方法。同时提供了Force Editor程序来建立效果。
对于VB爱好者来说，新的SDK库终于提供了完整的对VB的支持，现在终于可以使用Visual Basic来编写DirectX的程序了。
一、DirectX SDK库的安装
微软提供的SDK库是一个“重”达129M的dx7sdk.exe自解压缩文件，你可以上网下载或者从配套光盘上获得这个文件。双击文件就会弹出Winzip自解压缩对话框。在弹出的WinZip Self-Extract DK7SDK.EXE窗口中输入解压缩文件的路径，然后点击“Unzip”按钮解压缩SDK文件，解压缩界面如图1-1所示：
要注意的是，dx7sdk.exe解压缩之后的体积有220M，硬盘比较紧张的读者在解压缩之前首先看看你的硬盘的容量是否足够。
解压缩完毕之后，进入解压缩的目录中，双击Setup.exe文件就可以安装DirectX7.0 SDK文件了。安装是采用标准的InstallShield界面，玩Windows的读者应该对这种安装界面驾轻就熟，只要跟着安装提示一步一步的走就可以了。安装完毕之后，安装程序会在开始菜单中添加一个Microsoft DirectX 7 SDK的菜单，其中包括了DirectX 7设置工具、VB范例和SDK Help等菜单项。
现在开始进入VB，开始我们的DirectX的VB编程。在这里我们使用的是VB6企业版（英文）。Windows98中文版。
打开VB，点击菜单中的 Project | References 项，在Object Library 列表中会有一项：DirectX 7.0 For Visual Basic Type Library 列表项，这个就是DirectX7.0 VB类库，选中该项，再选“ok”按钮，就可以将库加入工程文件中。
二、DirectX编程初步
1 DirectX7对象
DirectX7对象是DirectX VB对象中其他所有对象的服务和起使对象，这个对象包含了建立诸如DirectDraw、Direct3D、DirectSound、DirectInput等对象的方法。同时该对象还包含了一系列的三维控件顶点和距阵的操作函数以及一些DirectX系统函数。在VB中可以通过Dim…New来直接定义和初始化一个DirectX7对象，例如：
Dim DirectX As New DirectX7
当建立成功一个DirectX7对象之后，就可以使用该对象的DirectDrawCreate、Direct3DRMCreate等方法建立DirectDraw、Direct3D对象了。
DirectX7对象范例1：获得系统中的DirectDraw和DirectSound驱动
建立一个新的工程文件，点击菜单中的 Project | References 项，在Object Library 列表中选中DirectX 7.0 For Visual Basic Type Library 项后按确定按钮（以下的程序都需要这个步骤，后面将不在做说明）。然后在Form1中加入一个ListBox控件和四个CommandButton控件，然后在Form1的代码窗口中加入以下代码：
Option Explicit
Dim DirectX As New DirectX7
Dim DDEnum As DirectDrawEnum
Dim DDSound As DirectSoundEnum
Private Sub Command1_Click()
Dim Count, i As Integer
Set DDEnum = DirectX.GetDDEnum
Count = DDEnum.GetCount
List1.Clear
For i = 1 To Count
List1.AddItem DDEnum.GetDescription(i)
Next i
Set DDEnum = Nothing
End Sub
Private Sub Command2_Click()
Dim Count, i As Integer
Set DDEnum = DirectX.GetDDEnum
Count = DDEnum.GetCount
List1.Clear
For i = 1 To Count
List1.AddItem DDEnum.GetName(i)
Next i
Set DDEnum = Nothing
End Sub
Private Sub Command3_Click()
Dim Count, i As Integer
Set DDSound = DirectX.GetDSEnum
Count = DDSound.GetCount
List1.Clear
For i = 1 To Count
List1.AddItem DDSound.GetDescription(i)
Next i
End Sub
Private Sub Command4_Click()
Dim Count, i As Integer
Set DDSound = DirectX.GetDSEnum
Count = DDSound.GetCount
List1.Clear
For i = 1 To Count
List1.AddItem DDSound.GetName(i)
Next i
End Sub
Private Sub Form_Load()
Command1.Caption = ”DirectDraw驱动描述“
Command2.Caption = ”DirectDraw驱动名称“
Command3.Caption = ”DirectSound驱动描述“
Command4.Caption = ”DirectSound驱动名称“
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set DirectX = Nothing
End Sub
运行程序，分别点击不同的按钮，在列表框中就会出现相应的设备驱动名和描述。
2 DirectDraw7对象
DirectDraw是一个与Windows 图形系统接口(GDI)相兼容的直接操作显示设备的软件接口。DirectDraw提供与硬件无关性的同时允许直接操作显存。程序只要使用一些基本的标准硬件约定如：RGB及YUV色彩格式及解析度。你无须调用特殊的过程来使用显存块移动(Blitter)及调色板。使用DirectDraw，你可简单操作显存，完全使用各种硬件特性而不必理会各种不同硬件之间的差异。
2.1 建立DirectDraw对象
DirectDraw7对象是DirectX7中的DirectDraw对象，你需要首先建立一个DirectX7对象，然后使用该对象的DirectDrawCreate方法来建立DirectDraw7对象。例如：
Dim DX As New DirectX7
Dim DDraw As DirectDraw7
Set DDraw = DX.DirectDrawCreate(”“)
2.2 建立协作层
当建立了一个DirectDraw对象之后，首先要设定DirectDraw的协作层。实现的方法是调用DirectDraw对象的SetCooperativeLevel函数。该函数的定义是：
object.SetCooperativeLevel( hdl As Long, flags As CONST_DDSCLFLAGS)
其中参数hdl指定程序的窗口句柄，参数flag决定程序运行的方式，函数调用
DDraw.SetCooperativeLevel Me.hWnd, DDSCL_NORMAL
将使程序运行于普通的协作层既窗口模式之下。在这种协作层你无法改变主平面调色板或进行页交换，因为程序可以使用多窗口。而函数调用
DDraw.SetCooperativeLevel MainForm.hWnd, DDSCL_EXCLUSIVE Or _
DDSCL_FULLSCREEN
将使程序运行于全屏幕模式之下。在全屏幕协作模式之下你可以完全使用硬件的一切。在这个模式之下，你可以设置使用定义及动态调色板，改变显示分辨率及进行页交换。
2.3 设置显示模式
设置显示模式是使用SetDispalyMode函数实现的，函数的定义如下：
object.SetDisplayMode( _
w As Long, _
h As Long, _
bpp As Long, _
ref As Long, _
mode As CONST_DDSDMFLAGS
其中参数w、h分别指定屏幕的宽度和高度，bpp指定屏幕显示的颜色位数，参数ref指定屏幕的刷新频率，设置为0使用显示驱动的缺省刷新频率，mode指定附加的参数。要获得系统支持的显示模式，可以使用DirectDraw对象的GetDisplayModesEnum函数来遍历所有支持的显示模式。
2.4 建立平面对象
一个平面或者说DirectDrawSurface对象是DirectDraw中图形显示和绘制对象。用户可以在DirectDrawSurface上贴位图、绘制图形，还可以直接操作DirectDrawSurface对象使用的显存里的内容。利用DirectDraw对象的CreateSurface方法可以建立一个DirectDrawSurface7对象。例如：
Public DDSFrontDesc As DDSURFACEDESC2
With DDSFrontDesc
.lFlags = DDSD_CAPS
.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE 注释：
End With
Set DDSFront = DDraw.CreateSurface(DDSFrontDesc)
也可以利用DirectDraw对象的CreateSurfaceFromFile函数或者CreateSurfaceFromResource函数建立一个DirectDrawSurface7对象，同时将图象文件或者资源文件中的图象装入建立的DirectDrawSurface中。如果上面的函数调用成功，函数将返回一个DirectDrawSurface对象。如果在设定DirectDraw对象的协作层时将其设置为全屏幕模式的话，为了改善图象性能，可以设立一个主平面和若干个屏下缓冲平面，首先在屏下平面中生成图象，然后将图象翻转到主平面上，这样可以有效的避免图象闪烁。
下面通过一个具体的范例来对DirectDraw进行说明：这个范例建立一个全屏幕的DirectDraw对象，通过操作主显示平面的显示内存在屏幕上显示火焰字的特效，然后按Enter键可以将DirectDraw平面中的图形保存起来。程序的具体实现如下：
建立一个新的工程文件，点击菜单中的 Project | Reference 选项，打开Object Library 列表窗口，将DirectX 7.0 For Visual Basic Type Library 加入工程文件。将Form1的Name属性改变为MainForm，在MainForm中加入一个PictureBox控件，将其的Visible属性设置为False。然后在MainForm的代码窗口中加入以下代码：
Private Sub Form_KeyPress(KeyAscii As Integer)
Dim sRect As RECT
Dim hdcSrc As Long
If KeyAscii = 27 Then
ExitLoop = True
注释：End
ElseIf KeyAscii =vbKeyReturn Then
DDSFront.BltToDC Picture1.hDC, sRect, sRect
With Picture1
注释：获得与主显示平面兼容的图形设备句柄
hdcSrc = DDSFront.GetDC
注释：保存图象
Set .Picture = SaveTohBmp(hdcSrc, 0, 0, 640, 480)
注释：释放图形句柄
DDSFront.ReleaseDC hdcSrc
SavePicture Picture1, ”c:a.bmp“
End With
End If
End Sub
Public Sub Form_Paint()
BlitRect.Right = DDSBackDesc.lWidth
BlitRect.Bottom = DDSBackDesc.lHeight
DDSFront.Blt BlitRect, DDSBack, BlitRect, DDBLT_WAIT
End Sub
在工程文件中加入一个Module文件，这个文件中将对DirectDraw操作做出定义，中加入以下代码：
Option Explicit
Public DX As New DirectX7
Public DDraw As DirectDraw7
Public DDSFront As DirectDrawSurface7
Public DDSFrontDesc As DDSURFACEDESC2
Public DDSBack As DirectDrawSurface7
Public DDSBackDesc As DDSURFACEDESC2
Public Clipper As DirectDrawClipper
Dim Pict() As Byte
Dim AlphaRect As RECT
Dim X As Long, Y As Long
Dim Temp As Long
Dim Index As Long
Dim Index2 As Long
Dim Pos As Long
Dim PosPlus1 As Long
Dim PosPlus2 As Long
Dim PosPlus3 As Long
Public Pal(255) As PALETTEENTRY
Public Palette As DirectDrawPalette
Public BlitRect As RECT
Public FullSize As Boolean
Public ExitLoop As Boolean
Dim Aclearcase/” target=“_blank” >ccum As Long
Dim Msg(9) As String
Dim Counter As Long
Dim MsgIndex As Long
Dim bDrawText As Boolean
Dim lastTime As Long
DimXPos As Long, YPos As Long
Dim wait As Long
Dim Angle As Single
Dim Flag As Boolean
Dim Count As Long
Dim CurModeActiveStatus As Boolean
Dim bRestore As Boolean
Dim Mode As Boolean
Private Sub Main()
InitializeDX
注释：初始化Picture1以获得DirectDraw界面图象
With MainForm.Picture1
.Width = 640 * Screen.TwipsPerPixelX
.Height = 480 * Screen.TwipsPerPixelY
End With
DDSBack.SetForeColor RGB(255, 255, 255)
MainForm.Font.Name = “宋体”
DDSBack.SetFont MainForm.Font
Msg(0) = “一个显示火焰字的演示”
Msg(1) = “演示”
Msg(2) = “利用VB阵列”
Msg(3) = “对显示内存”
Msg(4) = “进行直接存取”
Msg(5) = “键推出”
注释：设置8位的调色板
For Index = 0 To 84
Pal(Index + 1).red = Index * 3 + 3
Pal(Index + 1).green = 0
Pal(Index + 1).blue = 0
Pal(Index + 86).red = 255
Pal(Index + 86).green = Index * 3 + 3
Pal(Index + 86).blue = 0
Pal(Index + 171).red = 255
Pal(Index + 171).green = 255
Pal(Index + 171).blue = Index * 3 + 3
Next
Set Palette = DDraw.CreatePalette(DDPCAPS_8BIT _
Or DDPCAPS_ALLOW256, Pal())
DDSFront.SetPalette Palette
AlphaRect.Right = DDSBackDesc.lWidth - 1
AlphaRect.Bottom = DDSBackDesc.lHeight - 1
DDSBack.Lock AlphaRect, DDSBackDesc, DDLOCK_WAIT, 0
DDSBack.GetLockedArray Pict()
For X = 0 To 639
For Y = 0 To 479
Pict(X, Y) = 0
Next
Next
注释：Corresponding unlock
DDSBack.Unlock AlphaRect
While Not ExitLoop
Mode = ExModeActive
bRestore = False
Do Until ExModeActive
DoEvents
bRestore = True
Loop
DoEvents
If bRestore Then
bRestore = False
DDraw.RestoreAllSurfaces
End If
DDSBack.Lock AlphaRect, DDSBackDesc, DDLOCK_WAIT, 0
DDSBack.GetLockedArray Pict()
For Y = 0 To 479
Pict(0, Y) = 0
Pict(639, Y) = 0
Next
For X = 0 To 639
Pict(X, 477) = Rnd * 220 + 35
Pict(X, 478) = Rnd * 220 + 35
Pict(X, 479) = Rnd * 220 + 35
Next
Accum = 0
For X = 1 To 638
For Y = 0 To 477
Accum = (Accum + Pict(X, Y + 1) _
+ Pict(X, Y + 2) _
+ Pict(X + 1, Y + 1) _
+ Pict(X - 1, Y + 1)) 5
If Accum < 0 Then
Accum = 0
ElseIf Accum >255 Then
Accum = 255
End If
Pict(X, Y) = Accum
Next
Next
For X = 0 To 639
Pict(X, 0) = 0
Pict(X, 1) = 0
Next
X = Rnd * 639
For Y = 50 To 439
Next
注释：Unlock
DDSBack.Unlock AlphaRect
If DX.TickCount() - lastTime >wait Then
If Counter = 0 Then
bDrawText = True
Counter = 1
XPos = Rnd * 200
YPos = 300 + Rnd * 140
wait = 400
ElseIf Counter = 1 Then
MsgIndex = MsgIndex + 1
If MsgIndex >5 Then MsgIndex = 0
bDrawText = False
Counter = 0
wait = 2000
End If
lastTime = DX.TickCount
End If
注释：Draw Text to the backbuffer
If bDrawText Then
On Error Resume Next
DDSBack.DrawText XPos, YPos, Msg(MsgIndex), False
On Error GoTo 0
End If
MainForm.Form_Paint
Wend
TerminateDX
End
End Sub
Function ExModeActive() As Boolean
Dim TestCoopRes As Long
TestCoopRes = DDraw.TestCooperativeLevel
Select Case TestCoopRes
Case DDERR_NOEXCLUSIVEMODE
ExModeActive = False
Case DD_OK
ExModeActive = True
End Select
End Function
Public Sub InitializeDX()
MainForm.Left = 0
MainForm.Top = 0
MainForm.Height = 640 * Screen.TwipsPerPixelY
MainForm.Width = 480 * Screen.TwipsPerPixelX
MainForm.Show
注释：建立DirectDraw对象
Set DDraw = DX.DirectDrawCreate(“”)
注释：设定DirectDraw对象的协作层
DDraw.SetCooperativeLevel MainForm.hWnd, DDSCL_EXCLUSIVE Or DDSCL_FULLSCREEN 注释： DDSCL_NORMAL
注释：设定显示模式位640x480x8位颜色
DDraw.SetDisplayMode 640, 480, 8, 0, DDSDM_DEFAULT
注释：设定DDSFrontDesc为主平面
With DDSFrontDesc
.lFlags = DDSD_CAPS
.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE 注释：Or DDSCAPS_SYSTEMMEMORY
End With
注释：设定DDSBackDesc为后台缓冲平面
With DDSBackDesc
.ddsCaps.lCaps = DDSCAPS_SYSTEMMEMORY
.lFlags = DDSD_CAPS Or DDSD_WIDTH Or DDSD_HEIGHT
.lWidth = 640
.lHeight = 480
End With
注释：建立平面
Set DDSFront = DDraw.CreateSurface(DDSFrontDesc)
Set DDSBack = DDraw.CreateSurface(DDSBackDesc)
Set Clipper = DDraw.CreateClipper(0)
Clipper.SetHWnd MainForm.hWnd
DDSFront.SetClipper Clipper
DDSBack.SetClipper Clipper
DoEvents
Exit Sub
ERRoUT:
If Not (DDraw Is Nothing) Then
DDraw.RestoreDisplayMode
DDraw.SetCooperativeLevel MainForm.hWnd, DDSCL_NORMAL
DoEvents
End If
MsgBox “无法对DirectDraw进行初始化 ” + Chr(13) + “也许你的显示卡不支持 640x480x8 显示模式 ”
End
End Sub
Public Sub TerminateDX()
注释：子程序TerminateDX回复原来的显示模式并且释放所有的DirectDraw有关对象
DDraw.RestoreDisplayMode
DDraw.SetCooperativeLevel MainForm.hWnd, DDSCL_NORMAL
DoEvents
Set Clipper = Nothing
Set DDSBack = Nothing
Set DDSFront = Nothing
Set DDraw = Nothing
Set DX = Nothing
End Sub
在工程文件中在加入一个Module，这个Module主要定义与图象保存相关的操作，加入以下代码：
Option Explicit
Option Base 0
Private Type PALETTEENTRY
peRed As Byte
peGreen As Byte
peBlue As Byte
peFlags As Byte
End Type
Private Type LOGPALETTE
palVersion As Integer
palNumEntries As Integer
palPalEntry(255) As PALETTEENTRY 注释： Enough for 256 colors.
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Const RASTERCAPS As Long = 38
Private Const RC_PALETTE As Long = &H100
Private Const SIZEPALETTE As Long = 104
Private Declare Function CreateCompatibleDC Lib “GDI32” _
(ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib “GDI32” _
(ByVal hDC As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long) As Long
Private Declare Function GetDeviceCaps Lib “GDI32” _
(ByVal hDC As Long, _
ByVal iCapabilitiy As Long) As Long
Private Declare Function GetSystemPaletteEntries Lib “GDI32” _
(ByVal hDC As Long, _
ByVal wStartIndex As Long, _
ByVal wNumEntries As Long, _
lpPaletteEntries As PALETTEENTRY) As Long
Private Declare Function CreatePalette Lib “GDI32” _
(lpLogPalette As LOGPALETTE) As Long
Private Declare Function SelectObject Lib “GDI32” _
(ByVal hDC As Long, _
ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib “GDI32” _
(ByVal hDCDest As Long, _
ByVal XDest As Long, _
ByVal YDest As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal hdcSrc As Long, _
ByVal XSrc As Long, _
ByVal YSrc As Long, _
ByVal dwRop As Long) As Long
Private Declare Function DeleteDC Lib “GDI32” _
(ByVal hDC As Long) As Long
Private Declare Function GetForegroundWindow Lib “USER32” () As Long
Private Declare Function SelectPalette Lib “GDI32” _
(ByVal hDC As Long, _
ByVal hPalette As Long, _
ByVal bForceBackground As Long) As Long
Private Declare Function RealizePalette Lib “GDI32” _
(ByVal hDC As Long) As Long
Private Declare Function GetWindowDC Lib “USER32” _
(ByVal hWnd As Long) As Long
Private Declare Function GetDC Lib “USER32” _
(ByVal hWnd As Long) As Long
Private Declare Function GetWindowRect Lib “USER32” _
(ByVal hWnd As Long, _
lpRect As RECT) As Long
Private Declare Function ReleaseDC Lib “USER32” _
(ByVal hWnd As Long, _
ByVal hDC As Long) As Long
Private Declare Function GetDesktopWindow Lib “USER32” () As Long
Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type
Private Declare Function OleCreatePictureIndirect Lib “olepro32.dll” (PicDesc As PicBmp, RefIID As _
GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Public Function SaveTohBmp(ByVal hdcSrc As Long, ByVal LeftSrc As Long, _
ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture
Dim hDCMemory As Long
Dim hBmp As Long
Dim hBmpPrev As Long
Dim r As Long
Dim hPal As Long
Dim hPalPrev As Long
Dim RasterCapsScrn As Long
Dim HasPaletteScrn As Long
Dim PaletteSizeScrn As Long
Dim LogPal As LOGPALETTE
注释：
注释：建立一个内存图形设备句柄
hDCMemory = CreateCompatibleDC(hdcSrc)
注释：建立一个bitmap并保存到hDCMemory中
hBmp = CreateCompatibleBitmap(hdcSrc, WidthSrc, HeightSrc)
hBmpPrev = SelectObject(hDCMemory, hBmp)
注释： Get screen properties.
RasterCapsScrn = GetDeviceCaps(hdcSrc, RASTERCAPS) 注释： Raster
注释： capabilities.
HasPaletteScrn = RasterCapsScrn And RC_PALETTE 注释： Palette
注释： support.
PaletteSizeScrn = GetDeviceCaps(hdcSrc, SIZEPALETTE) 注释： Size of
注释： palette.
If HasPaletteScrn And (PaletteSizeScrn = 256) Then
注释：建立系统调色板的拷贝
LogPal.palVersion = &H300
LogPal.palNumEntries = 256
r = GetSystemPaletteEntries(hdcSrc, 0, 256, LogPal.palPalEntry(0))
hPal = CreatePalette(LogPal)
hPalPrev = SelectPalette(hDCMemory, hPal, 0)
r = RealizePalette(hDCMemory)
End If
注释：将屏幕图形拷贝到内存图形设备句柄中
r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hdcSrc, LeftSrc, TopSrc, vbSrcCopy)
hBmp = SelectObject(hDCMemory, hBmpPrev)
If HasPaletteScrn And (PaletteSizeScrn = 256) Then
hPal = SelectPalette(hDCMemory, hPalPrev, 0)
End If
注释：释放图形设备句柄
r = DeleteDC(hDCMemory)
Debug.Print r
注释：调用CreateBitmapPicture函数从指定的bitmap对象和调色板中建立一个picture对象
Set SaveTohBmp = CreateBitmapPicture(hBmp, hPal)
End Function
Public Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
Dim r As Long
Dim Pic As PicBmp
Dim IPic As IPicture
Dim IID_IDispatch As GUID
注释：填充IDispatch界面
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
注释：填充Pic结构
With Pic
.Size = Len(Pic) 注释： Length of structure.
.Type = vbPicTypeBitmap 注释： Type of Picture (bitmap).
.hBmp = hBmp 注释： Handle to bitmap.
.hPal = hPal 注释： Handle to palette (may be null).
End With
注释：建立Picture对象
r = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
注释：返回Picture对象
Set CreateBitmapPicture = IPic
End Function
运行程序，在屏幕上会出现一些火焰字的特效，按Enter键可以将屏幕保存到”c:a.bmp”中，按Esc键退出程序回到Windows，
在上面的程序中，程序首先建立一个DirectDraw对象，然后设置该对象的协作层为全屏协作模式，接下来设置显示模式为640x480x8位颜色，建立一个前台DirectDrawSurface对象和一个后台缓冲DirectDrawSurface对象，建立和设置DirectDrawClipper对象。
在主程序段中，程序首先对前台绘图平面的调色板（DirectDrawPalette）对象进行操作以改变显示的文字的颜色，然后对后台缓冲绘图平面进行字节操作，以产生文字弥散的效果，然后在将后台缓冲绘图平面翻转到前台。当用户按下Enter键之后，程序获得与前台绘图平面相兼容的图形设备句柄，然后再调用Windows API函数将绘图平面内存中的内容保存到Windows位图文件中。
上面粗略的介绍了DirectX7 SDK的新特性以及初步的DirectDraw编程，希望对大家能有所帮助。以上的程序在Windows98、VB6.0下运行通过。
原文转自：www.ltesting.net
【编写VB打印控制程序的几点心得】相关文章：
1.vb试题
2.vb教学设计
3.vb实习报告
5.打印策划书
6.vb试题及答案
9.3d打印教学计划
10.灯谜打印模板
文档为doc格式
