Rick 's BLOG

VC VB 的混合编译(三)

rick — 2005-04-11 10:11:49

在上一回我们已经实现VB调用VC函数并传递一个long、窗口句柄、字符串指针、结构体指针的参数，并取得了函数的返回值。这一回我们将实践一下如何传递多个参数。
打开上一回的两个工程(LinkWithVC, vcobj). 切换到VB在form上添加一个按钮 name: cmdTestStruct2, 标题 Test Struct 2。再在ModVC中添加如下代码
Public Function TestArg(lppt1 As POINTAPI, lppt2 As POINTAPI) As Long
Rem
End Function
在cmdTestStruct2的Click事件中
Private Sub cmdTestStruct2_Click()
Dim pt1 As POINTAPI, pt2 As POINTAPI
Call TestArg(pt1, pt2)
MsgBox "x= " & pt1.x & " y=" & pt1.y & vbCrLf & "x= " & pt2.x & " y=" & pt2.y
End Sub
好，现在生成EXE，必然不成功。我们打开log看会是什么错误信息，
Microsoft (R) Incremental Linker Version 6.00.8447
Copyright (C) Microsoft Corp 1992-1998. All rights reserved.

Form1.OBJ : error LNK2001: unresolved external symbol "private: void __stdcall ModVC::TestArg(void)" (?TestArg@ModVC@@AAGXXZ)
F:\LinkWithVC\LinkWithVC.exe : fatal error LNK1120: 1 unresolved externals
我们看到连接器要求的函数声明和无参数，1 个参数的相同，经过测试不能在VB模块声明的函数有多少个参数编译后都是 private: void __stdcall FunctionName(void ) 。
好了我们熟练的在VC的类中加上对应的TestArg函数。编译，生成EXE，通过。
下面来解决我们的难题，现在我们从VC程序的角度来说函数声明是一样的参数个数却是不确定的。这时我们应该会想到C 函数中有一种可变参数的函数，这种函数要求至少有一个确定参数，然后使用一组宏获取其它参数。这里我们先复习一下 C语言中可变参数的用法
http://rickw.cn/blogview.asp?logID=67
复习完了我们知道函数该怎么写了，如下：
void ModVC::TestArg()
{
LPPOINT lppt1,lppt2;
va_list ap;
lppt1 = (LPPOINT)this;
va_start(ap,this);
lppt2 = va_arg(ap,LPPOINT);
lppt1->x = 123;
lppt1->y = 456;
lppt2->x = 321;
lppt2->y = 654;
}
这样子，能行吗，编译试试;
-------------------Configuration: vcobj - Win32 Release--------------------
Compiling...
ModVC.cpp
F:\LinkWithVC\vcobj\ModVC.cpp(72) : error C2102: '&' requires l-value
Error executing cl.exe.

ModVC.obj - 1 error(s), 0 warning(s)
显然编译失败了。
This 是一个 r－value，无法取地址。现在我们知道只要取得了this的地址我们的问题就解决了。那怎么知道this的地址呢。。。不知道大家有什么好方法没有，老实说，我没有，如果谁有更好的方法别忘了告诉我一声哦。
不过我有一个很笨的方法：跟踪调试程序在内存中找答案。
为了便于调试我更改函数内容为如下：
void ModVC::TestArg()
{
char p[256];
lstrcpy(p,"break here!");
_asm mov eax,1;
_asm mov eax,2;
_asm mov eax,3;
_asm mov eax,this;
_asm mov eax,4;
_asm mov eax,5;
_asm mov eax,6;
}
编译，生成EXE。我们现在使用ollydbg来调试 LinkWithVC.exe，打开这个程序，使用od的搜功能，搜索参考字符串，然后在 break here! 哪里设置一个断点。运行程序，点按钮，程序会在下面红色的地方中断。
004012C0  /$ 55             PUSH EBP
004012C1  |. 8BEC           MOV EBP,ESP
004012C3  |. 81EC 00010000  SUB ESP,100
004012C9  |. 8D85 00FFFFFF  LEA EAX,DWORD PTR SS:[EBP-100]
004012CF  |. 68 30604000    PUSH LinkWith.00406030   ; /String2 = "break here!"
004012D4  |. 50             PUSH EAX               ; |String1 = 0012F300
004012D5  |. FF15 C0104000  CALL DWORD PTR DS:[<&KERNEL32.lstrcpyA>] ; \lstrcpyA
004012DB  |. B8 01000000    MOV EAX,1
004012E0  |. B8 02000000    MOV EAX,2
004012E5  |. B8 03000000    MOV EAX,3
004012EA  |. 8B45 08        MOV EAX,DWORD PTR SS:[EBP+8]
004012ED  |. B8 04000000    MOV EAX,4
004012F2  |. B8 05000000    MOV EAX,5
004012F7  |. B8 06000000    MOV EAX,6
004012FC  |. 8BE5           MOV ESP,EBP
004012FE  |. 5D             POP EBP
004012FF  \. C2 0400        RETN 4
看看上面蓝色的代码，如是我们知道那条绿色的代码对应的源程序就是 mov eax, this;
如是我们知道了this的地址就是 [ebp+8].

点击下载此文件

VC_VB的混合编译(二)实践进阶片

rick — 2005-04-07 12:50:11

在上一回我们已经实现VC,VB代码的混合编译,并成功的在VB代码中调用了VC代码中的一个无参数的函数,并取得了函数的返回值. 这一回我们将实践一下如何调用带参数的函数.
打开上一会的两个工程(LinkWithVC, vcobj). 切换到VB在form上添加一个按钮 name: cmdTestLong, 标题 TestLong. 在form上添加一个文本框txtInput 内容填 8. 再在ModVC中添加如下代码:
Public Function TestLong(ByVal lng As Long) As Long
TestLong = -1
End Function
在cmdTestLong的Click事件中添加代码 msgbox Testlong(clng(txtInput.Text))
现在我们来生成EXE. 显然生成会失败,打开log文件看看.
Microsoft (R) Incremental Linker Version 6.00.8447
Copyright (C) Microsoft Corp 1992-1998. All rights reserved.

Form1.OBJ : error LNK2001: unresolved external symbol "private: void __stdcall ModVC::TestLong(void)" (?TestLong@ModVC@@AAGXXZ)
F:\LinkWithVC\LinkWithVC.exe : fatal error LNK1120: 1 unresolved externals
看到了吗,和第一次看到的错误Log除了函数名,完全是一样的……这时候想到了什么? 参数呢? 在VB代码中明明是有参数申明的啊? ….先不管它, 和上回一样在VC类中添加一个名为TestLong的同类型的空函数. 编译vc的obj,再生成VB的EXE,运行点击 TestLong按钮, 我们看到msgbox提示8, 和我们的参数8 一样!! 是巧合? 试试改改 txtInput 中的数字. 再点击TestLong按钮. 我们会发现 msgbox提示的和txtInput文本框中的数字是一样的. 有了上回返回值的经验, 而我们的函数什么也没有做, 如是我们会知道这个参数就是存放在 eax中的, 好了到了这里我们知道怎么在VC代码中获取 vb代码传递的参数了. 可是在传递一个 long 型的数据有什么实际用途呢?  一个 long 它就意味着一个长整形数字、一个句柄、一个指针….我们来看一个实际的例子。
在Form上添加一个按钮cmdTestHwnd在按钮 TestHwnd的 Click事件中添加代码 call TestLong(txtInput.hWnd)
这里我们传递的是一个textbox的句柄。
我在VC函数中添加如下代码
void ModVC::TestLong()
{
long hw;
_asm mov hw,eax; //取得参数(TextBox的句柄)
SetWindowText((HWND)hw,"VC: Hello VB");

}
重复操作，生成我们的EXE，。。。我们会发现失败了，打开log看看。
Microsoft (R) Incremental Linker Version 6.00.8447
Copyright (C) Microsoft Corp 1992-1998. All rights reserved.

ModVC.OBJ : error LNK2001: unresolved external symbol __imp__SetWindowTextA@8
F:\LinkWithVC\LinkWithVC.exe : fatal error LNK1120: 1 unresolved externals
熟悉VC的一看就知道连接的时候没有把User32.lib连接进去。
解决方法有两个1个是在VC代码中使用LoadLibray,GetProcessAddress的方式调用这个api，另一个方法就是让连接器把user32.Lib连接进去。显然如果要大量使用api函数的话第一中方法太繁琐。我们用第二个方法。怎么做了呢？还记得上一回的自定义连接配置文件吗。
[Settings]
lib=1
log=1

[OBJ]
F:\LinkWithVC\vcobj\Release\ModVC.obj=F:\LinkWithVC\ModVC.obj

[lib]
1=User32.lib
Settings段的lib 表示 [lib]段中的lib数目。在lib段我按照顺序1=…,2=… 添加我们要连接的lib即可，当然也可以是obj文件。
好我们再来操作，生成EXE，OK。运行点击TestHwnd。好了我们看到TextBox中的文字变成了 VC: Hello VB 。
我们再来试试字符串。
在form上添加一个按钮TestString 在ModVC中添加函数
Public Function TestString(ByVal s As String) As Long
Rem nothing
End Function
TestString的Click事件中添加如下代码
Private Sub CmdTestString_Click()
Dim s As String
s = Space(256) '为s分配空间
Call TestString(s)
MsgBox s
End Sub
在VC中添加同名函数
void ModVC::TestString()
{
char* p;
_asm mov p,eax; //取得参数(TextBox的句柄)
memset(p,0,256);//我们知道字符串的长度是256
lstrcpy(p,"VC: Hello VB");

}
编译，生成EXE，运行，点击TestString按钮，。。。咦，显示的是乱码！！？？这是因为VB中的String用的是Unicode，VC中复制的不是。转一下就可以了。就在vb中转吧vb有一个函数很方便。把msgbox s 改为 MsgBox StrConv(s, vbUnicode)，再生成EXE运行，这次OK了。
接下来我们再试试传递结构体。函数参数格式的声明我们可以参考一下VB中API函数的声明。我来个简单点的结构体 POINTAPI, 用VB的 API Viewer 找到
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Public Type POINTAPI
        x As Long
        y As Long
End Type
参这个我们在ModVC中添加函数
Public Function TestStruct(lppt As POINTAPI) As Long
Rem
End Function
在form上添加一个按钮TestStruct，在Click中添加代码
Private Sub cmdTestStruct_Click()
Dim pt As POINTAPI
Call TestStruct(pt)
MsgBox "x= " & pt.x & " y=" & pt.y
End Sub
在VC类中添加同名同类型函数。
void ModVC::TestStruct()
{
POINT *pt;
_asm mov pt,eax;//获取指针参数
pt->x = 123;
pt->y = 456;
}
编译运行。。。。我们会发现非法操作。大概是说引用了0x00000000处的内存。看这个内存地址我们会知道在vc中引用了一个空指针，那就是说eax的值是0。那则么回事参数没有在eax里面，参数跑哪里去了？在其它寄存器？不太可能。。。那会在哪里呢，我们总不能凭空变出来一个参数吧。想想C++类中有什么可以用的符号？嗯，有一个 this 指针。会是它吗，熟悉VC的人应该知道在调用类成员函数时会先将该类的this指针存放到 eax 中。看来他们有很大的关系。那就动手试试。函数改为如下：
void ModVC::TestStruct()
{
POINT *pt=(POINT)this;
pt->x = 123;
pt->y = 456;
}
再编译，生成EXE运行。OK！成功了，看到了 x= 123 y=456 .
我们再回过头来看看前面的函数，都假设把this 当着参数试试，经过测试假设成立。如是我们知道this 就是传递过来的参数，当参数是long是，同时eax中也有这个参数值的一个副本。
到现在看来似乎是大功告成了，还没有！还有一个难题，this就只有一个，如果要传递2个，3个，4个。。。参数怎么办呢？

点击下载此文件

VC_VB的混合编译(一) 原理片

rick — 2005-04-07 12:44:57

原理:
Visual Basic 从5.0起就可以象C++那样将程序编译成本地码.VB将程序中的每个form, bas, cls, vbp 编译为obj文件,然后再调用连接程序将它们连接成EXE, 这个过程是自动的,连接完成后它会自动删除中介生成的OBJ文件. 要实现我们的目的就需要在连接程序连接输出EXE之前对OBJ文件进行处理,将C++编译的OBJ文件换进去.
准备:
我们需要自己些一个连接程序,当然这个程序不是要实现连接的功能,只需要实现预先处理 OBJ 文件, 获取VB传递给连接程序的参数, 对参数进行必要的修改, 然后调用原连接程序完成连接工作. 我们将vb目录下的Link.exe 改名为 vblink.exe, 再将我们写的link.exe 放到这个目录中. 这个Fake Link 程序我已经完成了, 在压缩包包中可以找到.
先讲讲这个Fake Link 程序是怎么工作的:
首先程序取得 VB 传递给连接程序的参数.
通过对参数进行分析获取当前所编译的VB工程文件的完整路径.(如:F:\ LinkWithVC\ LinkWithVC.vbp), 然后程序会查找该工程对应的自定义连接配置文件(F:\LinkWithVC\ LinkWithVC_link.ini), 如果找不到程序什么也不做直接调用vblink.exe.
如果找到了,就读取里面的设置,按照设置进行相应的处理,最后调用 vblink.exe.
InI文件的配置将在下面实践测试中做介绍．
实践测试:
运行VB6新建一个工程,工程名设为LinkWithVC, 给工程添加一个模块(bas), 名称设为 ModVC.
给窗体添加一个按钮名称 cmdTest, 标题 Test. 在ModVC中添加
Public Function Test() As Long
Test = 9
End Function
在cmdTest的Click事件中添加代码 msgbox test, 保存工程,编译运行,点击按钮我们会看到

是9没错就是 9 .
现在我们启动VC6新建一个空的Win32工程名称就叫vcobj,目录就设置为VB工程LinkWithVC所在的目录.
在工程中添加一个Generic Class ,类的名称就叫ModVC, 设置活动配置为 Win32 release. 现在就点击 Build 菜单中的 Compile ModVC.cpp 将它编译成OBJ文件.
然后在VB工程目录下建一个文件 LinkWithVC_link.ini.在文件中输入如下内容:
[Settings]
lib=0
log=1

[OBJ]
F:\LinkWithVC\vcobj\Release\ModVC.obj=F:\LinkWithVC\ModVC.obj

[lib]
注:F:\LinkWithVC是VB工程所在目录,F:\linkWithVC\vcobj是VC工程所在目录.
Ini文件有三个段.Settings段有lib 它表示需要附加的lib的数量. 相应的lib在lib段中定义.
OBJ段就是OBJ替换定义段可以是 vc的obj=vb的obj. Fake Link程序会自动用vc的obj替换vb的obj文件.
Log为1表示生成连接记录. 有记录便于排错.
好了现在我们切换到VB工程来生成LinkWithVC.exe
完了我们会发现并没有生成EXE, 打开log文件看看,会看到如下内容:
Microsoft (R) Incremental Linker Version 6.00.8447
Copyright (C) Microsoft Corp 1992-1998. All rights reserved.

Form1.OBJ : error LNK2001: unresolved external symbol "private: void __stdcall ModVC::Test(void)" (?Test@ModVC@@AAGXXZ)
F:\LinkWithVC\LinkWithVC.exe : fatal error LNK1120: 1 unresolved externals
看到拉,连接出错了 unresolved external symbol private: void __stdcall ModVC::Test(void) ,这个是正常的,我们替换了ModVC.obj,而我们的VC的modvc.obj并没有定义这个函数.接下来就是解决这个问题了.知道怎么做了吧,…现在切换到VC,在类ModVC中定义一个private的函数void __stdcall Test();函数体先空着.再编译它. 然后切换到VB生成EXE.好了生成了EXE文件了,我们运行它,点击按钮,会看到:

是10不是9,显然替换成功了,可是为什么是10呢…我也不清楚….(:P)
Void的函数怎么返回值呢? 在Windows中函数返回值一般都是存放在eax中的, 我们来试试.在 Test的函数体中添加代码 _asm mov eax , 123, 再重复前面的操作生成EXE,运行:

看到了123是不是很兴奋啊. 不要高兴得太早,返回值解决了,可是怎么给函数传递参数呢?

点击下载此文件

用VB写MOUSE穿透的窗体

rick — 2005-04-06 01:12:33

MOUSE穿透，就是写一个半透明的窗体，点击窗体的时候它下面的程序产生事件。

---------------------------------------------------------------

[复制到剪贴板]



 
Const  LWA_COLORKEY  =  &H1  
Const  LWA_ALPHA  =  &H2  
Const  GWL_EXSTYLE  =  (-20)  
Const  WS_EX_LAYERED  =  &H80000  
Private  Declare  Function  GetWindowLong  Lib  "user32"  Alias  "GetWindowLongA"  (ByVal  hWnd  As  Long,  ByVal  nIndex  As  Long)  As  Long  
Private  Declare  Function  SetWindowLong  Lib  "user32"  Alias  "SetWindowLongA"  (ByVal  hWnd  As  Long,  ByVal  nIndex  As  Long,  ByVal  dwNewLong  As  Long)  As  Long  
Private  Declare  Function  SetLayeredWindowAttributes  Lib  "user32"  (ByVal  hWnd  As  Long,  ByVal  crKey  As  Long,  ByVal  bAlpha  As  Byte,  ByVal  dwFlags  As  Long)  As  Long  
Private  Sub  Form_Load()  
 
       Dim  Ret  As  Long  
       Ret  =  GetWindowLong(Me.hWnd,  GWL_EXSTYLE)  
       Ret  =  Ret  Or  WS_EX_LAYERED  
       SetWindowLong  Me.hWnd,  GWL_EXSTYLE,  Ret  
       'Set  the  opacity  of  the  layered  window  to  200  
       SetLayeredWindowAttributes  Me.hWnd,  0,  200,  LWA_ALPHA  
End  Sub

---------------------------------------------------------------

再加上WS_EX_TRANSPARENT就能穿透鼠标了：

[复制到剪贴板]



 
Const  LWA_COLORKEY  =  &H1  
Const  LWA_ALPHA  =  &H2  
Const  GWL_EXSTYLE  =  (-20)  
Const  WS_EX_LAYERED  =  &H80000  
Const  WS_EX_TRANSPARENT  As  Long  =  &H20&  
Private  Declare  Function  GetWindowLong  Lib  "user32"  Alias  "GetWindowLongA"  (ByVal  hWnd  As  Long,  ByVal  nIndex  As  Long)  As  Long  
Private  Declare  Function  SetWindowLong  Lib  "user32"  Alias  "SetWindowLongA"  (ByVal  hWnd  As  Long,  ByVal  nIndex  As  Long,  ByVal  dwNewLong  As  Long)  As  Long  
Private  Declare  Function  SetLayeredWindowAttributes  Lib  "user32"  (ByVal  hWnd  As  Long,  ByVal  crKey  As  Long,  ByVal  bAlpha  As  Byte,  ByVal  dwFlags  As  Long)  As  Long  
Private  Sub  Form_Load()  
 
       Dim  Ret  As  Long  
       Ret  =  GetWindowLong(Me.hWnd,  GWL_EXSTYLE)  
       Ret  =  Ret  Or  WS_EX_LAYERED  Or  WS_EX_TRANSPARENT  
       SetWindowLong  Me.hWnd,  GWL_EXSTYLE,  Ret  
       'Set  the  opacity  of  the  layered  window  to  200  
       SetLayeredWindowAttributes  Me.hWnd,  0,  200,  LWA_ALPHA  
End  Sub

让vb自动改变控件的大小

rick — 2004-08-06 21:37:12

当窗体大小改变时，如何动态的改变控件的大小是许多VB程序员头痛
的事。有的人设置窗体Resizable但却不改变控件的大小；有的人则根据
控件的绝对位置与窗口大小相加减的办法来重新定位控件与改变大小，这
种办法比较繁琐，且不可重用；当然也有人则限定窗口干脆不让改变。有
没有一种简便易行的办法？答案是肯定的，下面给出一个一劳永逸的办法，
源程序如下:
Option Explicit
Private FormOldWidth As Long
'保存窗体的原始宽度
Private FormOldHeight As Long
'保存窗体的原始高度
'在调用ResizeForm前先调用本函数
Public Sub ResizeInit(FormName As Form)
Dim Obj As Control
FormOldWidth = FormName.ScaleWidth
FormOldHeight = FormName.ScaleHeight
On Error Resume Next
For Each Obj In FormName
Obj.Tag = Obj.Left & " " & Obj.Top & " "
& Obj.Width & " " & Obj.Height & " "
Next Obj
On Error GoTo 0
End Sub
'按比例改变表单内各元件的大小，
在调用ReSizeForm前先调用ReSizeInit函数
Public Sub ResizeForm(FormName As Form)
Dim Pos(4) As Double
Dim i As Long, TempPos As Long, StartPos As Long
Dim Obj As Control
Dim ScaleX As Double, ScaleY As Double
ScaleX = FormName.ScaleWidth / FormOldWidth
'保存窗体宽度缩放比例
ScaleY = FormName.ScaleHeight / FormOldHeight
'保存窗体高度缩放比例
On Error Resume Next
For Each Obj In FormName
StartPos = 1
For i = 0 To 4
'读取控件的原始位置与大小
TempPos = InStr(StartPos,
Obj.Tag, " ", vbTextCompare)
If TempPos ＞ 0 Then
Pos(i) = Mid(Obj.Tag,
StartPos, TempPos - StartPos)
StartPos = TempPos + 1
Else
Pos(i) = 0
End If
'根据控件的原始位置及窗体改变大小
的比例对控件重新定位与改变大小
Obj.Move Pos(0) * ScaleX, Pos(1)
＊ ScaleY, Pos(2) * ScaleX, Pos(3) * ScaleY
Next i
Next Obj
On Error GoTo 0
End Sub
Private Sub Form_Load()
Call ResizeInit(Me) '在程序装入时必须加入
End Sub
Private Sub Form_Resize()
Call ResizeForm(Me) '确保窗体改变时控件随之改变
End Sub

——本例中给出了二个函数:ResizeInit和ResizeForm,在调用ResizeForm
之前必须先调用ResizeInit。你可以将本程序拷到窗体代码段里，然后在
窗体里加入任意控件即可进行测试。

利用VB捕捉并保存屏幕图像

rick — 2004-08-06 21:33:35

大家知道在VB下利用API函数Bitblt可以将屏幕或者窗口上的图像拷贝到VB中

的PictureBox对象中，但是如果简单地利用PictureBox的SavePicture函数来保存

图像，会发现什么也保存不了。这篇文章就是介绍如何捕获并利用Windows下的OLE

API函数保存图像。

　　首先来看源程序，先建立一个新的工程文件，然后在Form1中加入5个

CommandButton对象和一个PictureBox对象，然后在Form1中加入以下代码：

　　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 Type RECT

　　Left As Long

　　Top As Long

　　Right As Long

　　Bottom As Long

　　End Type

　　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

　　'捕捉整个屏幕

　　Private Sub Command1_Click()

　　Set Picture1.Picture = CaptureScreen()

　　End Sub

　　'在两秒钟后捕捉当前的活动窗口

　　Private Sub Command2_Click()

　　MsgBox“当你关闭这个对话框两秒钟之后程序会捕捉处于活动状态的窗口。

"

　　'等待两秒钟

　　Dim EndTime As Date

　　EndTime = DateAdd(“s", 2, Now)

　　Do Until Now > EndTime

　　DoEvents

　　Loop

　　Set Picture1.Picture = CaptureActiveWindow()

　　Me.SetFocus

　　End Sub

　　Private Sub Command3_Click()

　　Set Picture1.Picture = Nothing

　　End Sub

　　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)

　　' Pic结构长度

　　.Type = vbPicTypeBitmap

　　' 图像类型

　　.hBmp = hBmp

　　' 位图句柄

　　.hPal = hPal

　　' 调色板句柄

　　End With

　　'建立Picture图像

　　r = OlecreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)

　　'返回Picture对象

　　Set createBitmapPicture = IPic

　　End Function

　　Public Function CaptureWindow(ByVal hWndSrc As Long, ByVal Client As

Boolean, 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 hDCSrc 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

　　If Client Then

　　hDCSrc = GetDC(hWndSrc)

　　Else

　　hDCSrc = GetWindowDC(hWndSrc)

　　End If

　　hDCMemory = createCompatibleDC(hDCSrc)

　　hBmp = createCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)

　　hBmpPrev = selectObject(hDCMemory, hBmp)

　　'获得屏幕属性

　　RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS)

　　HasPaletteScrn = RasterCapsScrn And RC_PALETTE

　　PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE)

　　'如果屏幕对象有调色板则获得屏幕调色板

　　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)

　　r = ReleaseDC(hWndSrc, hDCSrc)

　　Set CaptureWindow = createBitmapPicture(hBmp, hPal)

　　End Function

　　'capturescreen函数捕捉整个屏幕图像

　　Public Function CaptureScreen() As Picture

　　Dim hWndScreen As Long

　　'获得桌面的窗口句柄

　　hWndScreen = GetDesktopWindow()

　　Set CaptureScreen = CaptureWindow(hWndScreen, False, 0, 0, Screen.

Width _ \ Screen.TwipsPerPixelX, Screen.Height \ Screen.

TwipsPerPixelY)

　　End Function

　　Public Function CaptureActiveWindow() As Picture

　　Dim hWndActive As Long

　　Dim r As Long

　　Dim RectActive As RECT

　　hWndActive = GetForegroundWindow()

　　r = GetWindowRect(hWndActive, RectActive)

　　Set CaptureActiveWindow = CaptureWindow(hWndActive, False, 0, 0, _

　　RectActive.Right － RectActive.Left, RectActive.Bottom －

RectActive.Top)

　　End Function

　　Public Sub PrintPictureToFitPage(Prn As Printer, Pic As Picture)

　　Const vbHiMetric As Integer = 8

　　Dim PicRatio As Double

　　Dim PrnWidth As Double

　　Dim PrnHeight As Double

　　Dim PrnRatio As Double

　　Dim PrnPicWidth As Double

　　Dim PrnPicHeight As Double

　　If Pic.Height >= Pic.Width Then

　　Prn.Orientation = vbPRORPortrait

　　Else

　　Prn.Orientation = vbPRORLandscape

　　End If

　　PicRatio = Pic.Width / Pic.Height

　　PrnWidth = Prn.ScaleX(Prn.ScaleWidth, Prn.ScaleMode, vbHiMetric)

　　PrnHeight = Prn.ScaleY(Prn.ScaleHeight, Prn.ScaleMode, vbHiMetric)

　　PrnRatio = PrnWidth / PrnHeight

　　If PicRatio >= PrnRatio Then

　　PrnPicWidth = Prn.ScaleX(PrnWidth, vbHiMetric, Prn.ScaleMode)

　　PrnPicHeight = Prn.ScaleY(PrnWidth / PicRatio, vbHiMetric, Prn.

ScaleMode)

　　Else

　　PrnPicHeight = Prn.ScaleY(PrnHeight, vbHiMetric, Prn.ScaleMode)

　　PrnPicWidth = Prn.ScaleX(PrnHeight ＊ PicRatio, vbHiMetric, Prn.

ScaleMode)

　　End If

　　Prn.PaintPicture Pic, 0, 0, PrnPicWidth, PrnPicHeight

　　End Sub

　　Private Sub Command4_Click()

　　CommonDialog1.DefaultExt =“.BMP"

　　CommonDialog1.Filter =“Bitmap Image (＊.bmp)|＊.bmp"

　　CommonDialog1.ShowSave

　　If CommonDialog1.FileName <> “" Then

　　SavePicture Picture1.Picture, CommonDialog1.FileName

　　End If

　　End Sub

　　Private Sub Command5_Click()

　　PrintPictureToFitPage Printer, Picture1.Picture

　　Printer.EndDoc

　　End Sub

　　Private Sub Form_Load()

　　Command1.Caption = “捕捉整个屏幕"

　　Command2.Caption = “两秒钟后捕捉活动窗口"

　　Command3.Caption = “清除图像"

　　Command4.Caption = “保存图像"

　　Command5.Caption = “打印图像"

　　End Sub

　　运行程序，点击command1或者Command2就可以捕捉整个屏幕或者窗口到

Picture1中，然后点击Command4或者Command5就可以保存或打印图像。

　　上面的程序中最重要的是CaptureWindow函数以及createBitmapPicture函数，

CaptureWindow函数建立与要捕捉的窗口的绘图设备（Device Context）句柄相兼

容的绘图设备（Device Context）句柄，然后建立相应的调色板，最后将绘图设备

（Device Context）中的图像拷贝到一个hBitmap对象句柄中。

createBitmapPicture函数则根据传递过来的hBitmap对象句柄和调色板句柄建立一

个Picture对象。再将这个对象赋予PictureBox的Picture属性，然后就可以使用

SavePicture函数来保存图像了。

　　OlecreatePictureIndirect函数支持的不仅有BMP图像，同时也支持Ico图标，

所以利用该函数和ExtractIcon函数也可以提取并保存Windows文件中的图标。

隐藏任务栏

rick — 2004-08-06 21:31:46

下面的代码就可以轻松搞定。
    Private Const SWP_HIDEWINDOW = &H80
Private Const SWP_SHOWWINDOW = &H40
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Function SetWindowPos Lib "user32" Alias "SetWindowPos" (ByVal hwnd As Long, ByVal hWndinsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Function SetWindowPos Lib "user32" Alias "SetWindowPos" (ByVal hwnd
Public Sub ViewTaskBar(lbValue As Boolean)
Dim llResult As Long
llResult = FindWindow("Shell_traywnd", "")
If llResult Then
If lbValue Then


llResult = SetWindowPos(llResult, 0, 0, 0, 0, 0, SWP_SHOWWINDOW)         Else           llResult = SetWindowPos(llResult, 0, 0, 0, 0, 0, SWP_HIDEWINDOW)
End If
    End If
  End Sub
调用过程ViewTaskBar,lbValue为false时隐藏任务栏。

使本程序不出现在Windows的结束任务对话框中 (win9x)

rick — 2004-08-06 21:30:46

想做到这一点,你必须将你的程序注册为一个Service,这将通过把你的应用程序的Pro

cess ID传递给RegisterService API

声明部分:

将一下这些代码复制到模块的声明部分

Public Declare Function GetCurrentProcessId _

Lib "kernel32" () As Long

Public Declare Function GetCurrentProcess _

Lib "kernel32" () As Long

Public Declare Function RegisterServiceProcess _

Lib "kernel32" (ByVal dwProcessID As Long, _

ByVal dwType As Long) As Long

Public Const RSP_SIMPLE_SERVICE = 1

Public Const RSP_UNREGISTER_SERVICE = 0

过程:

调用MakeMeService使你的程序不出现在结束任务对话框中

Public Sub MakeMeService()

Dim pid As Long

Dim reserv As Long

Dim reserv As Long

pid = GetCurrentProcessId()

regserv = RegisterServiceProcess(pid, RSP_SIMPLE_SERVICE)

End Sub

使你的程序重新出现在结束任务对话框中,调用UnMakeMeService

Public UnMakeMeService()

Dim pid As Long

Dim reserv As Long

pid = GetCurrentProcessId()

regserv = RegisterServiceProcess(pid, _

RSP_UNREGISTER_SERVICE)

'End Code

不要忘了在关闭你的程序时调用UnMakeService来注销其Service来释放系统资源

VB中创建可以输出函数的DLL

rick — 2004-08-06 19:54:29

VB中创建的DLL只是COM组件，无法作为输出函数的DLL。今天从袁波哪里搞到一种可以创建
输出函数的DLL的方法。
VB编译文件实际上采取了两次编译的方法，首先是调用c2.exe产生OBJ文件，然后调用Lin
k.exe连接。如果在link的时候添加EXPORT选项，实际上是可以输出函数的。但是，在VB的
工程选项中将这些屏蔽了。而且过分的是：VB在Build完成后会将OBJ文件删除，这样就无
法通过Link来输出函数了。不过我找到一个比较龌鹾的变通的方法，就是先创建一个Exe工
程，在Form_Load事件里面写下面的语句:

Private Sub Form_Load()
    If (MsgBox("hehe", vbOKCancel) = vbOK) Then
        Shell "link2.exe " & Command$
    End If
End
End Sub

然后编译为linktemp.exe，接下来将LINK.EXE改名为Link2.exe，将linktemp.exe改名为l
ink.exe。这样在VB调用link.exe时会弹出对话框，处理就会中断。这时就可以有机会将O
BJ文件拷贝出来了 J

然后我创建了一个ActiveX DLL工程，在这个工程里面添加一个Module并创建一个Public函
数mathadd：

Public Function mathadd(ByVal a As Long, ByVal b As Long) As Long
    mathadd = a + b
End Function

Builder这个工程，在Link的时候就会中断。然后把创建的Class1.obj、Module1.obj、Pr
oject1.obj备份出来。

然后就可以调用Link2.exe连接OBJ到DLL了，我的连接代码是：

link2.exe "e:\vbdll\Class1.obj" "e:\vbdll\Module1.obj" "e:\vbdll\Project1.obj"
"c:\Program Files\Microsoft Visual Studio\VB98\VBAEXE6.LIB" /ENTRY:__vbaS /EX
PORT:mathadd /OUT:"e:\vbdll\ProjectOK.dll" /BASE:0x11000000 /SUBSYSTEM:WINDOWS
,4.0 /VERS

注意里面的/ENTRY和/EXPORT开关，/EXPORT开关声明了输出函数mathadd。这样就大功告成
了 :-D，可以被其他语言引入，例如在VB中，只需要：

Private Declare Function mathadd Lib "e:\vbdll\ProjectOK.dll" (ByVal a As Long
, ByVal b As Long) As Long

就可以了。