365MASTER.COM's Archiver

redking 发表于 2006-1-9 13:29

<PRE>往列表框中填入文件目录信息   


 This routine demonstrated using the API and a standard listbox to duplicate the functionality of a FileList Box. By using this method over the FileListBox, you can control the files, directories and drives displayed. 

 Note however that the constant value for 'READWRITE' is 0, the same as the vb constant 'Archive'. In VB you can not mask out the archive files to only return hidden files (for example). But by using the API value DDL_EXCLUSIVE Or'd with the type to be listed, you have control over the display of files.

 The added bonus is that this method is instantaneous.

 Add the following code to a BAS module:
---------------------------------------------------------------

Public Declare Function SendMessageStr Lib _
 "user32" Alias "SendMessageA" _
 (ByVal hwnd As Long, _
  ByVal wMsg As Long, _
  ByVal wParam As Long, _
  ByVal lParam As String) As Long

Public Declare Function SendMessageLong Lib _
  "user32" Alias "SendMessageA" _
  (ByVal hwnd As Long, _
  ByVal wMsg As Long, _
  ByVal wParam As Long, _
  ByVal lParam As Long) As Long

Public Const LB_DIR = &amp;H18D
Public Const LB_RESETCONTENT = &amp;H184

Public Const DDL_READWRITE = &amp;H0
Public Const DDL_READONLY = &amp;H1
Public Const DDL_HIDDEN = &amp;H2
Public Const DDL_SYSTEM = &amp;H4
Public Const DDL_DIRECTORY = &amp;H10
Public Const DDL_ARCHIVE = &amp;H20
Public Const DDL_DRIVES = &amp;H4000
Public Const DDL_EXCLUSIVE = &amp;H8000
Public Const DDL_POSTMSGS = &amp;H2000
Public Const DDL_FLAGS = DDL_ARCHIVE Or DDL_DIRECTORY
'--end block--

-------------------------------------------------------------------
 Create a form containing six command buttons in a control array (Command1(0) - Command1(5)), and a listbox. Add the following code to the form:

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

Private Sub Command1_Click(Index As Integer)

  Dim r As Long
  Dim DDL_FLAGS As Long
  Dim searchPath As String

  searchPath = "c:\win\*.*"

  Select Case Index
   Case 0: DDL_FLAGS = DDL_EXCLUSIVE Or DDL_ARCHIVE
   Case 1: DDL_FLAGS = DDL_EXCLUSIVE Or DDL_ARCHIVE Or DDL_DIRECTORY
   Case 2: DDL_FLAGS = DDL_EXCLUSIVE Or DDL_HIDDEN
   Case 3: DDL_FLAGS = DDL_EXCLUSIVE Or DDL_SYSTEM
   Case 4: DDL_FLAGS = DDL_EXCLUSIVE Or DDL_DIRECTORY
   Case 5: DDL_FLAGS = DDL_EXCLUSIVE Or DDL_DRIVES
   Case Else
  End Select

 'clear and populate the listbox
  Call SendMessageLong(List1.hwnd, LB_RESETCONTENT, 0, 0)
  Call SendMessageStr(List1.hwnd, LB_DIR, DDL_FLAGS, ByVal searchPath)

  Label1 = r + 1 &amp; " " &amp; Command1(Index).Caption &amp; " found."

End Sub
'--end block--
-------------------------------------------------------------------

 By changing the value of the DDL_FLAGS parameter to include or exclude specific DDL_ constants, you determine the type of file structure to include into the list.

 For an explanation of my usage of SendMessageLong and SendMessageStr, see Using the Windows SendMessage API Successfully in the Resource Centre.  
</PRE>

redking 发表于 2006-1-9 13:30

<PRE>文本框中光标位置的获得
作者:陈锐
在很多的编辑软件中有这样一个功能,即当用户在编辑区中输入字符或者按动鼠标使得光标的位置改变时,在编辑软件下方的状态栏中就能显示出光标所在位置的行和列的值。下面就介绍如何用VB编程实现在文本框中的这一功能。
  首先,在Form中添加一个文本框(TextBox),将其MultiLine属性设置为True,以便输入多行文本;再在Form中添加两个标题栏(Label),以便显示光标位置;然后,在Form的代码窗口中添加程序中的代码。

Option Explici
Const EM_GETSEL = &amp;HB0
Const EM_LINEFROMCHAR = &amp;HC9
Const EM_LINEINDEX = &amp;HBB

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Public Sub GetCaretPos(ByVal TextHwnd As Long, LineNo As Long, ColNo As Long)

Dim I As Long, j As Long
Dim lParam As Long, wParam As Long
Dim k As Long

'首先向文本框传递EM_GETSEL消息以获取从起始位置到
'光标所在位置的字符数

I = SendMessage(TextHwnd, EM_GETSEL, wParam, lParam)
j = I / 2 ^ 16

'再向文本框传递EM_LINEFROMCHAR消息根据获得的字符
'数确定光标以获取所在行数

LineNo = SendMessage(TextHwnd, EM_LINEFROMCHAR, j, 0)
LineNo = LineNo + 1

'向文本框传递EM_LINEINDEX消息以获取所在列数

k = SendMessage(TextHwnd, EM_LINEINDEX, -1, 0)
ColNo = j - k + 1
End Sub

Private Sub Form_Load()
Dim LineNo As Long, ColNo As Long

Call GetCaretPos(Text1.hwnd, LineNo, ColNo)
Label1.Caption = LineNo
Label2.Caption = ColNo
End Sub

Private Sub Form_Resize()
Text1.Width = Me.ScaleWidth
End Sub

Private Sub Text1_KeyUp(KeyCode As Integer, Shift As Integer)
Dim LineNo As Long, ColNo As Long

Call GetCaretPos(Text1.hwnd, LineNo, ColNo)
Label1.Caption = LineNo
Label2.Caption = ColNo
End Sub

Private Sub Text1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim LineNo As Long, ColNo As Long

Call GetCaretPos(Text1.hwnd, LineNo, ColNo)
Label1.Caption = LineNo
Label2.Caption = ColNo
End Sub

(程序)

  运行上面的程序,在TextBox中输入字符或者按控制键来移动光标时,你可以看到屏幕下面的Label中就能显示出的光标所在的位置。以上程序在Win 95,VB 5.0下运行通过。

</PRE>

redking 发表于 2006-1-9 13:30

<PRE>无关联程序时开启“打开方式”窗口   
            
在使用资源管理器时,双击一个未建立关联的文件, 就会出现一个打开方式窗口。 而在程序中使用 ShellExecute 打开文件时, 如果没有关联程序,也可以打开该窗口。
声明:
Declare Function GetDesktopWindow Lib "user32" () As Long
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
Declare Function GetSystemDirectory Lib _
"kernel32" Alias "GetSystemDirectoryA" _
(ByVal lpBuffer As String, ByVal nSize _
As Long) As Long
Private Const SE_ERR_NOASSOC = 31
函数:
Public Sub ShellDoc(strFile As String)
Dim lngRet As Long
Dim strDir As String
lngRet = ShellExecute(GetDesktopWindow, _
"open", strFile, _
vbNullString, vbNullString, vbNormalFocus)
If lngRet = SE_ERR_NOASSOC Then
' 没有关联的程序
strDir = Space(260)
lngRet = GetSystemDirectory(strDir, _
Len(strDir))
strDir = Left(strDir, lngRet)
' 显示打开方式窗口
Call ShellExecute(GetDesktopWindow, _
vbNullString, "RUNDLL32.EXE", _
"shell32.dll,OpenAs_RunDLL " &amp; _
strFile, strDir, vbNormalFocus)
End If
End Sub
使用:
OpenDoc "c:\aa.log" </PRE>

redking 发表于 2006-1-9 13:31

<PRE>无论如何,就是只能输入数字
--------------------------------------------------------------------------------
●这一篇是Excel"事件"的运用成果之一,各位可以在这里看到Excel工作表的Change事件的运用方法。
●甲设我们要制做一个只能输入数字的功能,由于Excel没有KeyPress事件,这个就只能靠Sheet的Change事件来做事后诸葛了。我们把滑鼠游标移到Sheet最下方标示"Sheet1"处,然后按一下滑鼠右键。

●按下滑鼠右键蹦出跳出式功能表,选择"检视程式码",之后就会自动呼叫VisualBASIC编辑器。

●VisualBASIC编辑器会自动出现程式码编辑对话框,仔细看右图的左上角,它显示的物件自动变成WorkSheet,而右上角,我们选择Change事件(Cell内的文字被改变会引发的事件)。



●写入程式码:

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If IsNumeric(Target.Text) = False And Target.Text &lt;&gt; "" Then
'假如被变更的Cell内的资料不是数字并且不为空白
If Left(Target.Cells.Address, 2) = "$B" Then
'假如Cell位置是B拦位
MsgBox "B栏位整行都只能输入数字", 64
Range(Target.Address).Select
'则工作表上的输入游标自动回到刚才变更的Cell里
SendKeys "{F2}"
'送出F2,让使用者无法争脱直到输入数字为止
End If
End If
End Sub
</PRE>

redking 发表于 2006-1-9 13:31

<PRE>显示 Combo 的下拉条   
            
声明:
Public Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Const CB_SHOWDROPDOWN = &amp;H14F
使用:
'程序控制显示下拉条
r = SendMessageLong(Combo1.hWnd, CB_SHOWDROPDOWN, True, 0)
'程序控制隐藏下拉条
r = SendMessageLong(Combo1.hWnd, CB_SHOWDROPDOWN, False, 0)

确定 TextBox 有几行
声明:
Public Declare Function SendMessageLong Lib _ "user32" Alias "SendMessageA" (ByVal hwnd As Long, _ ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Const EM_GETLINECOUNT = &amp;HBA
使用:
lineCount = SendMessageLong(Text1.hwnd, EM_GETLINECOUNT, 0&amp;, 0&amp;)

TextBox 中英文输入方法切换 98-7-22
IMEMode 属性可以方便地控制输入方法:
Text1.IMEMode = 0 '初始值
Text1.IMEMode = 1 '中文输入
Text1.IMEMode = 2 '英文输入
Text1.IMEMode = 3 '禁止中文输入</PRE>

redking 发表于 2006-1-9 13:32

<PRE>显示Windows系统的标准ABOUT窗口
吴斌
 ABOUT窗口是应用程序向用户传达自身一些基本信息的最佳方式。Windows系统的
许多软件,如程序管理器、文件管理器、书写器等,都带有一个风格一致的ABOUT
窗口。在这些软件中,只要选择“帮助”菜单命令“关于XXX...”,就会弹出
这个标准ABOUT窗口,其中显示有关Windows及相应软件的版本、工作方式和版权等
信息。在VB应用程序中,可以通过调用API函数ShellAbout,方便地借用这个标准
ABOUT窗口,并将自己的基本信息加入其中。
  首先,在module文件中加入下列声明语句:
  Declare Function ExtractIcon% Lib "shell.dll" (ByVal hinst%, ByVal
lpszExeName$,ByVal iIcon%)
  Declare Function GetWindowWord Lib "User"( ByVal hWnd As Integer,
ByVal nIndex As Integer)As Integer
  Declare Function ShellAbout Lib "shell.dll"(ByVal hWnd As Integer,
ByVal szApp As String,ByVal szOtherStuff As String,ByVal hIcon As
Integer)As Integer
  Public Const GWL_EXSTYLE=(-20)
  Public Const GWL_STYLE=(-16)
  Public Const GWL_WNDPROC=(-4)

Public Const GWW_HINSTANCE=(-6)

  然后,在调用ABOUT窗口的菜单项的Click事件中加入下列代码:
 Dim Ret As Integer
  Dim Icon As Integer
  Dim Inst As Integer
  Inst=GetWindowWord(Me.hWnd,GWW_HINSTANCE)
  '从可执行文件中抽取图标
  Icon=ExtractIcon(Inst,"DEMO.EXE",0)
  '调用Windows系统标准ABOUT窗口
  Ret=ShellAbout (Me.hWnd,"1234","123" &amp; Chr$(13) &amp; Chr$(10) &amp; "
123456",Icon)


</PRE>

redking 发表于 2006-1-9 13:33

显示程序的版本 <BR><BR><BR>如果你想在程序的“关于……”中显示程序的版本(以标准方式显示:即 x.xx.xxxx),你可以使用以下子程序:<BR>Public Function GetMyVersion() As String<BR>Static strMyVer As String<BR>If strMyVer = "" Then<BR>strMyVer = Trim$(Str$(App.Major)) &amp; "." &amp; Format$(App.Minor, "##00") &amp; "." Format$(App.Revision, "000")<BR>End If<BR>GetMyVersion = strMyVer<BR>End Function<BR><BR>

redking 发表于 2006-1-9 13:34

<PRE>显示窗口的水平和垂直滚动条


由于在外读书,上网都是在网吧,所以回答问题,通常都是三言二语,没有说清楚,不过这一篇可是在寝室的电脑上完成的,当然还有上次回答天水的那篇.我学VB的时候,根本没有交流,那种困难不言而喻.现在能与大家一起谈论VB,是我当初所不敢想象的.好了,言归正传,切入今天的话题----显示窗口的水平和垂直滚动条:
在Delphi中,它的TFORM类可以自动显示水平和垂直滚动条,这不能不让我们这些VB Fan们有些嫉妒,为了实现这个功能,我们不得不自已动手了.
首先从窗口谈起,窗口有许多风格,到API浏览器中可以看到许多以WS_或WS_EX_开头的常量,都是用来指定风格的.要实现水平和垂直滚动条就要修改窗口风格,同时还要响应来自滚动条的消息,才能实现其功能.其实我并不认为直接使用窗口自带的滚动条是一个好方法,使用滚动条控件要灵活的多,你可以在窗口中放入任意多的滚动条控件,但窗口自带的就只能有一个.但使用自带滚动条也有其优点,比如其位置不要用额外的代码进行调整,其它好像就没有了.
在使用方面来说,主要的难点在于其消息的响应,尤其对初学者来说,因为要构造一个子类窗口.其他的min,max值的设置,滚动框的位置的设定,都有对应的API函数来实现.
程序实现:
先在窗口上放两个Lable,两个Botton.

'1.窗口风格的设置
'在窗口声明部分加入
Dim HVisible as Boolean,VVisible as Boolean

Private Sub Form_Load()
Dim OldStyle As Long
Dim hsWidth As Integer
'保存旧风格
OldStyle = SetWindowLong(hWnd, GWL_STYLE, 0)
'设置新风格
Call SetWindowLong(hWnd, GWL_STYLE, OldStyle Or WS_VSCROLL Or WS_HSCROLL)
Command1.Caption = "隐藏垂直滚动条"
Command2.Caption = "隐藏水平滚动条"
Label1 = "垂直滚动条的值"
Label2 = "水平滚动条的值"
'得到水平滚动条的宽度
hsWidth = GetSystemMetrics(SM_CXVHSCROLL)
'改变窗口宽度与高度
Width = Width + hsWidth
Height = Height + hsHeight
VVisible = True
HVisible = True
'怎么样,滚动条显示出来了没有?没有?那么是我眼花了?@_@

'2.滚动范围的设置
yMin = 0: yMax = 100
xMin = 0: xMax = 100
SetScrollRange hWnd, SB_HORZ, xMin, xMax, True
SetScrollRange hWnd, SB_VERT, yMin, yMax, True
'建立子类窗口
SubClass Me
End Sub'End Of Form_Load

'3.滚动条的显示与隐藏
Private Sub Command1_Click()
If VVisible Then
Command1.Caption = "显示垂直滚动条"
ShowScrollBar hWnd, SB_VERT, False
VVisible = False
Else
Command1.Caption = "隐藏垂直滚动条"
ShowScrollBar hWnd, SB_VERT, True
VVisible = True
End If
End Sub

'4.子类窗口的撤消
Private Sub Form_Unload(Cancel As Integer)
UnSubClass Me
End Sub

'从1.窗口风格的设置直到此处都可以直接COPY到窗口代码中

'5.消息响应机制
'添加一个公共模块,在模块中加入以下代码和声明
Public Const SM_CXHSCROLL = 21
Public Const GWL_STYLE = (-16)
Public Const WS_HSCROLL = &amp;H100000
Public Const WS_VSCROLL = &amp;H200000
Public Const SB_BOTH = 3
Public Const SB_HORZ = 0
Public Const SB_VERT = 1
'以下以SB_开头的是用户的滚动请求
Public Const SB_LINEDOWN = 1
Public Const SB_LINELEFT = 0
Public Const SB_LINERIGHT = 1
Public Const SB_LINEUP = 0
Public Const SB_PAGERIGHT = 3
Public Const SB_PAGELEFT = 2
Public Const SB_PAGEDOWN = 3
Public Const SB_PAGEUP = 2
Public Const SB_ENDSCROLL = 8
Public Const SB_THUMBPOSITION = 4
Public Const SB_THUMBTRACK = 5
Public Const GWL_WNDPROC = (-4)
Public Const WM_HSCROLL = &amp;H114
Public Const WM_VSCROLL = &amp;H115
Public Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Declare Function ShowScrollBar Lib "user32" (ByVal hWnd As Long, ByVal wBar As Long, ByVal bShow As Long) As Long
Declare Function SetScrollPos Lib "user32" (ByVal hWnd As Long, ByVal nBar As Long, ByVal nPos As Long, ByVal bRedraw As Long) As Long
Declare Function SetScrollRange Lib "user32" (ByVal hWnd As Long, ByVal nBar As Long, ByVal nMinPos As Long, ByVal nMaxPos As Long, ByVal bRedraw As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public preWndProc As Long
Public xMin As Integer, xMax As Integer
Public yMin As Integer, yMax As Integer
Public xPos As Integer, yPos As Integer

Public Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
On Error Resume Next
Dim xInc As Integer, yInc As Integer
Select Case uMsg
Case WM_VSCROLL'垂直滚动条消息
Select Case LoWord(wParam)
Case SB_LINEUP, SB_LINEDOWN
If LoWord(wParam) Then
yInc = 1
Else
yInc = -1
End If
Case SB_PAGEUP, SB_PAGEDOWN
If LoWord(wParam) = SB_PAGEUP Then
yInc = -10
Else
yInc = 10
End If

Case SB_THUMBTRACK
yInc = HiWord(wParam) - yPos
End Select
yPos = yPos + yInc
If yPos &lt; yMin Then yPos = yMin
If yPos &gt; yMax Then yPos = yMax
SetScrollPos hWnd, SB_VERT, yPos, True
Form1.Label1 = yPos
Case WM_HSCROLL'垂直水平条消息
Select Case LoWord(wParam)
Case SB_LINELEFT, SB_LINERIGHT
If LoWord(wParam) Then
xInc = 1
Else
xInc = -1
End If
Case SB_PAGELEFT, SB_PAGERIGHT
If LoWord(wParam) = SB_PAGELEFT Then
xInc = -10
Else
xInc = 10
End If
Case SB_THUMBTRACK
xInc = HiWord(wParam) - xPos
End Select
xPos = xPos + xInc
If xPos &lt; xMin Then xPos = xMin
If xPos &gt; xMax Then xPos = xMax
SetScrollPos hWnd, SB_HORZ, xPos, True
Form1.Label2 = xPos
End Select
WindowProc = CallWindowProc(preWndProc, hWnd, uMsg, wParam, lParam)
End Function
Public Sub SubClass(frm As Form)
preWndProc = SetWindowLong(frm.hWnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub
Public Sub UnSubClass(frm As Form)
Call SetWindowLong(frm.hWnd, GWL_WNDPROC, preWndProc)
End Sub
'The function below is much useful in API development.
Private Function LoWord(num As Long) As Integer
LoWord = num Mod &amp;H10000
End Function
Private Function HiWord(num As Long) As Integer
HiWord = (num And &amp;HFFFF0000) / &amp;H10000
End Function
说明:
此程序调试比较困难,应注意不要用VB工具栏中的"结束"按钮来结束该程序,只能通过窗口上的"关闭"按钮,而且在程序中不能出错,否则VB就当掉了.

</PRE>

redking 发表于 2006-1-9 13:34

<PRE>显示文件属性对话框

利用ShellExecuteEx API函数可以调出文件的属性对话框。源代码如下:

Private Type SHELLEXECUTEINFO

cbSize As Long

fMask As Long

hWnd As Long

lpVerb As String

lpFile As String

lpParameters As String

lpDirectory As String

nShow As Long

hInstApp As Long

lpIDList As Long

lpClass As String

hkeyClass As Long

dwHotKey As Long

hIcon As Long

hProcess As Long

End Type

Private Declare Function ShellExecuteEx Lib _

"shell32" (lpSEIAs SHELLEXECUTEINFO) As Long

Private Const SEE_MASK_INVOKEIDLIST = &amp;HC

Private Sub Form_Click()

Call ShowFileProperties( _

"c:\windows\system\msvbvm50.dll")

End Sub

Private Sub ShowFileProperties(ByVal aFile As _

String)

Dim sei As SHELLEXECUTEINFO

sei.hWnd = Me.hWnd

sei.lpVerb = "properties"

sei.lpFile = aFile

sei.fMask = SEE_MASK_INVOKEIDLIST

sei.cbSize = Len(sei)

ShellExecuteEx sei

End Sub

</PRE>

redking 发表于 2006-1-9 13:36

<PRE>旋转字体
如何使自己设计的程序具有漂亮和友好的界面,是程序员间永恒的话题。这里,
笔者向您介绍一种非常简单的技巧,使文字旋转起来。
这里的“旋转字体”指的是让一行字体的水平基线(baseline)转过一定的角度。
正如您所看到的,旋转字体会产生轻松、活泼的视觉效果,可以给观者以特殊的联
想,是一种行之有效的显示特技。
有一种很容易想到的办法可以实现旋转字体,即首先生成文字的点阵(位图),
然后利用坐标旋转变换生成新的位图再输出到屏幕或打印机上。这种办法思路清晰,
不但可以用于字体的旋转,也可以用于其他种种字体变形,如同WinWord中的
WordArt或中文之星的“艺术汉字”。但这种办法实现起来比较麻烦,需要一些计
算机绘图学方面的知识,而且位图变换过程中需要占用较多的内存。而我们所要介
绍的方法,可以有效地解决这些问题,而且不需要什么专门的知识,而是充分地利
用Windows API已有的功能实现旋转字体的效果。
我们知道,逻辑字体是一类非常重要的Windows GDI对象。我们正是通过选择
不同的逻辑字体来输出各种秀美的字体的。而所谓“旋转字体”不过是一类特殊的
逻辑字体。如同其他的GDI对象(如画笔、画刷、调色板)一样,字体对象不但具有
固有的字体,我们也可以建立自己的逻辑字体。建立字体可以使用Windows API的
CreateFontIndirect()函数。在调用该函数之前,我们将字体的特征放入LOGFONT
结构变量中。LOGFONT结构是这样定义的:
Type LOGFONT
lfHeight As Integer ' 字体的高度
lfWidth As Integer ' 字体的宽度
lfEscapement As Integer ' 字体旋转的角度
lfOrientation As Integer
lfWeight As Integer ' 字体的轻重
lfItalic As String * 1 ' 是否为斜体
lfUnderline As String * 1 ' 是否有下划线
lfStrikeOut As String * 1 ' 是否有强调线
lfCharSet As String * 1 ' 字符集
lfOutPrecision As String * 1 ' 输出精度
lfClipPrecision As String * 1 ' 剪裁精度
lfQuality As String * 1 ' 输出质量
lfPitchAndFamily As String * 1 ' 间距和字体族
lfFaceName As String * LF_FACESIZE ' 字体名,如“宋体”
End Type

利用这个数据结构,你可以方便地设置各种字体参数,比如高度、宽度等。该
结构中同我们所要讨论的问题关系最大的是lfEscapement,它表示字符的基线同坐
标的X轴之间的旋转角度,从X轴正方向开始沿逆时针方向旋转,以十分之一度为单
位(图2)。蔡明志先生著的《Windows程序设计?绘图篇--使用Borland C++ for
Windows》一书(科学出版社1993年9月出版)的482页上指出旋转角度以十度为单位,
为此笔者查阅了SDK手册,其英文原文为:“measured in tenths of a degree”,
似应为以十分之一度为单位。
lfFaceName指明字体的名称,如“宋体”、“行楷”。需要指出的是,个别字
体不支持字体旋转,主要是字体宽度不可变的种类,如FixedSys就不支持字体旋转,
好在这样的字体只有一两种。
具体的实现参见文后所附的程序(用Visual Basic 3.0编写),其中RotPrint
过程用来输出旋转字体。其步骤如下:首先,利用GetObject()函数获得当前字体
的LOGFONT结构,修改lfEscapement,设置旋转角度,然后调用
CreateFontIndirect()函数建立逻辑字体并选用之。接下来,调用TextOut()函数
输出字符串。使用TextOut()函数可以使那些不支持Print方法的控制(如标签),
同样可以输出旋转字体。最后,用DeleteObject()函数删除建立的逻辑字体并恢复
原字体。
您可以通过示例程序的“选择”菜单中的“字体”项来尝试不同的字体效果,
从中选出令人满意的组合。

附录:源程序
ROTFONT.BAS文件:
DefInt A-Z
' 逻辑字体
Global Const LF_FACESIZE = 32 ' 最长的字体名称
Global Const SYSTEM_FONT = 13
Type LOGFONT
lfHeight As Integer
lfWidth As Integer
lfEscapement As Integer
lfOrientation As Integer
lfWeight As Integer
lfItalic As String * 1
lfUnderline As String * 1
lfStrikeOut As String * 1
lfCharSet As String * 1
lfOutPrecision As String * 1
lfClipPrecision As String * 1
lfQuality As String * 1
lfPitchAndFamily As String * 1
lfFaceName As String * LF_FACESIZE
End Type
'字体的族
Global Const FF_DONTCARE = 0 ' 无所谓
Global Const FF_ROMAN = 16 ' 字体宽度可变,Times Roman, Century
' Schoolbook等
Globa
</PRE>

redking 发表于 2006-1-9 13:37

<PRE>一劳永逸让VB自动改变控件大小


深圳市东门茂业百货11楼 邓 勇
   当窗体大小改变时,如何动态的改变控件的大小是许多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 &amp; " " &amp; Obj.Top &amp; " " _
      &amp; Obj.Width &amp; " " &amp; Obj.Height &amp; " "
  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 &gt; 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。你可以将本程序拷到窗体代码段里,然后在窗体里加入任意控件即可进行测试。

</PRE>

redking 发表于 2006-1-9 13:39

<PRE>移动没有标题栏的窗口   

我们一般是用鼠标按住窗口的标题栏,然后移动窗口,当窗口没有标题栏时,我们可以用下面的方法来移动窗口:
在 BAS 文件中声明:
Declare Function ReleaseCapture Lib "user32" () As Long Declare Function SendMessage Lib "user32" _ Alias "SendMessageA" ( _ ByVal hwnd As Long, ByVal wMsg As Long, _ ByVal wParam As Long, lParam As Any) As Long
Public Const HTCAPTION = 2
Public Const WM_NCLBUTTONDOWN = &amp;HA1
然后,在 Form_MouseDown 事件中:
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ReleaseCapture
SendMessage hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&amp;
End Sub</PRE>

redking 发表于 2006-1-9 13:41

<PRE>隐藏Win95任务栏   

作者:Showje

显示、隐藏win95任务栏

Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
 (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Declare Function ShowWindow Lib "user32" Alias "ShowWindow" _
 (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long

Public Const SW_SHOW = 5
Public Const SW_HIDE = 0

Private hwnd5 as Long

hwnd5 = FindWindow("Shell_traywnd","")
Call ShowWindow(hwnd5, SW_HIDE) '隐藏任务栏

Call ShowWindow(hwnd5, SW_SHOW) '显示任务栏

  这不是一个好的方式,如果你将任务栏隐藏了,但没有将之再显示出来,那我们只有重新启动才能使之重现,当用户发现叫不出任务栏时,他可能会很恼火。  
</PRE>

redking 发表于 2006-1-9 13:43

<PRE>用API函数打开 MS CommonDialog对话框

在模块中加入:
Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As- OPENFILENAME) As Long
Type OPENFILENAME
lStructSize As Long
hwndOwner As long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
然后在Form窗体上加一个文本框和按钮Caption属性为"打开".双击按钮加入下列代码:
Private Sub Command1_Click()
Dim ofn As OPENFILENAME
Dim rtn As String
ofn.lStructSize=len(ofn)
ofn.hwndOwner=Me.hWnd
ofn.hInstance=App.hInstance
ofn.lpstrFilter="所有文件"
ofn.lpstrFile=Space(254)
ofn.nMaxFileTitle=255
ofn.lpstrInitialDir=app.path
ofn.lpstrTitle="打开文件"
ofn.flags=6148
rtn=GetOpenFileName(ofn)
If rtn&gt;=1 then
Text1.Text=ofn.lpstrFile
Else
Text1.Text="Cancel Was Pressed"
End If
End Sub
运行程序,点击"打开"按钮就会弹出打开文件对话框.选中任何文件再确定,Text1.Text就会显示任何文件名.

</PRE>

redking 发表于 2006-1-9 13:44

<PRE>用API函数打开 MS CommonDialog对话框

在模块中加入:
Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As- OPENFILENAME) As Long
Type OPENFILENAME
lStructSize As Long
hwndOwner As long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
然后在Form窗体上加一个文本框和按钮Caption属性为"打开".双击按钮加入下列代码:
Private Sub Command1_Click()
Dim ofn As OPENFILENAME
Dim rtn As String
ofn.lStructSize=len(ofn)
ofn.hwndOwner=Me.hWnd
ofn.hInstance=App.hInstance
ofn.lpstrFilter="所有文件"
ofn.lpstrFile=Space(254)
ofn.nMaxFileTitle=255
ofn.lpstrInitialDir=app.path
ofn.lpstrTitle="打开文件"
ofn.flags=6148
rtn=GetOpenFileName(ofn)
If rtn&gt;=1 then
Text1.Text=ofn.lpstrFile
Else
Text1.Text="Cancel Was Pressed"
End If
End Sub
运行程序,点击"打开"按钮就会弹出打开文件对话框.选中任何文件再确定,Text1.Text就会显示任何文件名.

</PRE>

redking 发表于 2006-1-9 13:44

用VB5 制作“闪烁标题栏”窗体 <BR><BR><BR>  在一些Windows程序中,在特殊的时刻,程序窗体会闪烁标题栏以引起用户的注意,效果很好。其实,用VB5实现这种效果很容易。<BR>  具体步骤如下:<BR>  一、创建一个新工程,将如下代码加入到Form1的 “通用\声明”中:<BR>  Option Explicit<BR>  Private Declare Function FlashWindow Lib “user32”(ByVal hwnd As Long,ByVal bInvert As Long) As Long<BR>  二、向窗体Form1中加入一个定时器控件Timer1,设置如下属性:<BR>  Enabled:False<BR>  Interval:500<BR>  将下列代码加入到Timer1的Timer事件中:<BR>  Private Sub Timer1_ Timer()<BR>  FlashWindow hwnd,True<BR>  End Sub<BR>  三、向窗体Form1中加入两个按钮控件,设置如下属性:<BR>  Command1:<BR>  Caption:“闪烁标题栏”<BR>  Command2:<BR>  Caption:“停止闪烁”<BR>  将如下代码加入到Command1的Click事件中:<BR>  Private Sub Command1_ Click()<BR>  Timer1= True <BR>  End Sub<BR>  再将如下代码加入到Command2的Click事件中:<BR>  Private Sub Command2_ Click()<BR>  FlashWindow hwnd,False<BR>  Timer1= False<BR>  End Sub<BR>         

redking 发表于 2006-1-9 15:50

用VB实现浮动按钮 <BR><BR><BR>方法一.<BR>在微软的很多软件(如WORD)的工具栏中,都采用一种浮动按钮,即正常情况下按钮的图标呈灰色,当鼠标移动到某一按钮时,该按钮自动向上凸起且变为彩色,并在按钮的右下方有一标签提示该按钮的功能,鼠标移开后又自动还原,这种按钮用VB实现时,方法如下:<BR>1.先用绘图工具作出按钮图标后存盘(如1.bmp),再用图象处理软件将该图标转换为灰 度图或浮雕图后再存盘(如2.bmp)。<BR>2.运行VB,建立一新窗体(如form1)。<BR>3.在窗体上需要建立按钮的位置处建立一图片框(如image1),其大小和图标相同,并将 其picture属性设为2.bmp。<BR>4.在image1周围建立由四个长度相同的line控件(如line1~4)组成的方框,方框要比image1 控件稍大,否则达不到预计效果,将上面和左边的颜色设成白色,下面和右边的设成黑色, 并将四个line控件的visible属性都设成false 。<BR>5.在程序中加入以下内容即可:<BR>Private Sub Image1_MouseMove(Botton As Integer,Shift As Integer,X As Single,Y As Single)<BR>Image1.Picture=LoadPicture("c:\1.bmp")<BR>Line1.Visible=True<BR>Line2.Visible=True<BR>Line3.Visible=True<BR>Line4.Visible=True<BR>End Sub<BR>Private Sub Form1_MouseMove(Botton As Integer,Shift As Integer,X As Single,Y As Single)<BR>Image1.Picture=LoadPicture("c:\2.bmp")<BR>Line1.Visible=False<BR>Line2.Visible=False<BR>Line3.Visible=False<BR>Line3.Visible=False<BR>End Sub<BR><BR>方法二.<BR><BR>微软的Visual Basic确实是个好东东,编写应用程序快捷高效。但是入门容易,想玩转它可不简单。我个人学VB就深有体会:一个人在VB的殿堂里摸索是何等的辛苦啊!有时为了一个特技、一句代码甚至一个变量要反复调试运行几十遍,也未必能通过,真恨不得一枪崩了VB。所以,我连这一点点小技巧都不敢独品,拿出来与大家共享,也算抛砖引玉,引出更多、更精彩的奇思妙文,以“飨”读者。<BR>关于浮动按钮的实现思路不少,多是采取多图片重叠显示来实现。这种方法代码量多,实现起来较繁琐。因为,一个按钮还好,如果有十个按钮呢?一个按钮三个图片,十个就要三十个图片,可不是闹着玩的。<BR>我的思路是:<BR>舍弃CommandButton控件,每个按钮用4条Line控件和一个Label控件替代。4条Line围住Label的边缘,调入窗体时,置显示属性为False,并将左、上直线的颜色设为白色,右、下直线的颜色设为黑色。当鼠标移到Label上时,4条Line的显示属性置True;当鼠标离开按钮时,将4条Line的显示属性设置为False。这样在视觉上就完全得到立体浮动的效果。另外,VB的Line控件还支持直线倾斜,以此类推,完全可以做出更加美观的倾斜按钮。篇幅所限,下面仅给出一个按钮实现浮动效果的源代码。<BR>Option Explicit<BR>Private Sub Form_Load()<BR>'初始Form与Label<BR>Form1.Caption = “浮动按钮"<BR>Form1.KeyPreview = False<BR>label1.Caption = “确定"<BR>'初始4条Line的显示属性为False<BR>Line1.Visible = False<BR>Line2.Visible = False<BR>Line3.Visible = False<BR>Line4.Visible = False<BR>'初始4条Line的颜色<BR>Line1.BorderColor = &HE0E0E0<BR>Line2.BorderColor = &HE0E0E0<BR>Line3.BorderColor = &H808080<BR>Line4.BorderColor = &H808080<BR>End Sub<BR>Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)<BR>'鼠标指针在窗体上(不在按钮上)时,置4条Line的显示属性为False<BR>Line1.Visible = False<BR>Line2.Visible = False<BR>Line3.Visible = False<BR>Line4.Visible = False<BR>End Sub<BR>Private Sub label1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)<BR>'鼠标指针在按钮上时,置4条Line的显示属性为True<BR>Line1.Visible = True<BR>Line2.Visible = True<BR>Line3.Visible = True<BR>Line4.Visible = True<BR>End Sub<BR><BR>

redking 发表于 2006-1-9 15:59

<PRE>用VB5制作文字上卷效果

  什么是文字的上卷效果?就像电影结束时播报制作人员名单那样,文字徐徐上升。此效果在软件制作中也被广泛应用。其实,用VB5.0很容易制作这一效果。首先,在VB5.0中选择文件菜单,选择新建工程,选择标准EXE,确定。此时,自动创建默认窗口FORM1。在FORM1上建立一个PICTURE BOX控件,然后在PICTURE BOX控件上再建立一个TEXT控件。再在FORM1上建立一个COMMAND控件和TIMER控件。选中TEXT控件,打开属性窗口。把APPEARANCE属性设置为0 FLAT,BORDERSTYLE属性设为0 NONE,MULTILINE设置为TRUE。再选中TIMER控件,把INTERVEL 属性设为250。这时,可以给这些控件起名字,只要设置相应控件的CAPTION属性即可。这里默认的CAPTION 属性分别是FORM1、PICTUREBOX1、TEXT1、COMMAND1、TIMER1。
  接下来加入代码。这个程序很简单。在“通用”部分,加入:
  Option Explicit
  Dim CurY As Single ′ 定义变量,表示文本首
   部的当前高度
  COMMAND1控件部分加入:
  Private Sub Command1_Click()
  CurY = Picture1.Height
  Timer1.Enabled = True
  End Sub
  注解:当运行该程序,点击COMMADN1控件时,激活TIMER控件,并且把TEXT1中内容的当前位置放在PICTURE BOX的底部,开始徐徐上升。
  在窗口代码部分加入:
  Private Sub Form_Load()
  Dim STR As String, ENTER As String * 2 ′ 定义变量
  Picture1.BackColor = &H00000000 ′ PICTUREBOX的
   背景色为黑色
  Text1.BackColor = &H00000000 ′ TEXT的背景
   为黑色
  Text1.ForeColor = &H000000FF ′ TEXT中文字的
   前景色为红色
  Timer1.Enabled = False
  Text1 = ″ ″ ′把TEXT1的内容设为空串
  ENTER = Chr$(13) + Chr$(10)   ′回车,
   换行标志
  Open App.Path + “\AAA.txt" For Input As #1 ′ 文件
   AAA.txt是被播放的文本文件
  While Not EOF(1) ′从文件AAA.txt一行一行读入
   文本,并加上回车换行标志
  Line Input #1, STR
   Text1 = Text1 + STR + ENTER
  Wend ′循环结束
  Close #1 ′关闭文件输入输出通道
  Text1.Font.Size = 14 ′设置TEXT文本字体大小
  Set Font = Text1.Font ′设置字体
  Text1.Move 0, Picture1.Height ′把TEXT1的文本移动到
   PICTURE底部
  Text1.Width = Picture1.Width ′把TEXT1的文本宽度设
   置为PICTURE的宽度
  Text1.Height = TextHeight(Text1.Text) ′计算TEXT1文本
   的高度,并赋予HEIGHT属性
  End Sub
  在TIMER控件部分加入代码:
  Private Sub Timer1_Timer()
   Text1.Top = CurY ′把CURY的值赋予TEXT1
   的TOP属性
  CurY = CurY
</PRE>

redking 发表于 2006-1-9 16:01

<PRE>用VB6建立带光栅的超级开始菜单

  


  (一)编程原理;


  由于windows自身并未提供这项接口函数,因此我们必须从分析菜单的实质入手,我认为任何菜单实质上是一个没有标题栏的窗体,菜单项目是某些控件(如标签控件),通过监测鼠标是否移动到控件上而相应的改变控件的背景色和填充色,从而达到相应的目的,当然另外一项关键是如何制造出那一个倒立着的写着“windows98”字样的标题,这需要我们调用复杂的系统函数来实现。


  (二)编程实践;


  (1)运行vb6,建立一个标准exe工程,添加命名为form1的窗体,放上一个command控件“command1”,caption=“开始”,调整到适当的位置,双击窗体,写入以下代码:


  Private Sub Command1_Click()


  frmTest.Show ‘当开始按钮被点击时激活超级菜单


  End Sub


  Private Sub Form_Load()


  Me.left = (Screen.Width - Me.Width) / 2


  Me.tOp = (Screen.Height - Me.Height) / 2 ‘窗体位置居中


  End Sub


  Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)


  If frmTest.Visible = True Then


  Unload frmTest


  End If ‘当鼠标离开菜单时卸载菜单


  End Sub


  Private Sub Form_Unload(Cancel As Integer)


  End ‘结束程序


  End Sub


  (2) 添加命名为frmtest的窗体,添加一个picturebox控件,命名为piclogo,采用默认值就行了,添加控件数组label1(1--6)(读者可以根据自己的需要添加),caption=“菜单项目”,添加一个image控件,将它的图片设计为自己喜欢的图片,移动窗体和图片到适当位置,双击窗体,写入以下代码:


  Option Explicit


  Dim cL As New cLogo ‘引用类模块


  Private Sub Form_Load()


  Me.left = Form1.left


  Me.tOp = Form1.tOp - Form1.Height ‘指定窗体位置


  Me.Caption = App.Title ‘窗体标题


  cL.DrawingObject = picLogo ‘指定piclogo为载体


  cL.Caption = ″ 欢迎使用国产软件! --zouhero 2000 ″‘文本


  cL.StartColor = vbBlue ‘前段颜色-蓝色


  cL.EndColor = vbRed ‘后段颜色-红色


  End Sub


  Private Sub Form_Resize()


  On Error Resume Next


  picLogo.Height = Me.ScaleHeight


  cL.Draw


  End Sub


  Private Sub Label1_Click(Index As Integer)


  MsgBox ″你选择了菜单″ & Index, vbExclamation


  ’在这里添加你的相应代码


  End Sub


  Private Sub Label1_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)


  Dim i As Integer ‘当鼠标移动标签控件时,前景色变成白色,背景色变成蓝色


   Label1(Index).BackColor = vbBlue


   Label1(Index).ForeColor = &HFFFFFF


   For i = 0 To Label1.Count - 1 ‘其他标签颜色恢复原状


  If i = Index Then GoTo aa


  Label1(i).BackColor = vbButtonFace


  Label1(i).ForeColor = &H0


  aa:


  Next ‘恢复除选定标签外的所有标签的前景色和背景色


  End Sub ‘代码结束


  (3)选择“工程”菜单-“添加类模块”,命名为clogo,写入以下代码:


  Option Explicit ’以下是令人眼花缭乱的win api引用


  Private Type RECT


  left As Long


  tOp As Long


  Right As Long


  Bottom As Long


  End Type


  Private Declare Function FillRect Lib ″user32″ (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long


  Private Declare Function CreateSolidBrush Lib ″gdi32″ (ByVal crColor As Long) As Long


  Private Declare Function TextOut Lib ″gdi32″ Alias ″TextOutA″ (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long


  Private Declare Function GetDeviceCaps Lib ″gdi32″ (ByVal hDC As Long, ByVal nIndex As Long) As Long


  Private Const LOGPIXELSX = 88


  Private Const LOGPIXELSY = 90


  Private Declare Function MulDiv Lib ″kernel32″ (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long


  Private Const LF_FACESIZE = 32


  Private Type LOGFONT


  lfHeight As Long


  lfWidth As Long


  lfEscapement As Long


  lfOrientation As Long


  lfWeight As Long


  lfItalic As Byte


  lfUnderline As Byte


  lfStrikeOut As Byte


  lfCharSet As Byte


  lfOutPrecision As Byte


  lfClipPrecision As Byte


  lfQuality As Byte


  lfPitchAndFamily As Byte


  lfFaceName(LF_FACESIZE) As Byte


  End Type


  Private Declare Function CreateFontIndirect Lib ″gdi32″ Alias ″CreateFontIndirectA″ (lpLogFont As LOGFONT) As Long


  Private Declare Function SelectObject Lib ″gdi32″ (ByVal hDC As Long, ByVal hObject As Long) As Long


  Private Declare Function DeleteObject Lib ″gdi32″ (ByVal hObject As Long) As Long


  Private Const FW_NORMAL = 400


  Private Const FW_BOLD = 700


  Private Const FF_DONTCARE = 0


  Private Const DEFAULT_QUALITY = 0


  Private Const DEFAULT_PITCH = 0


  Private Const DEFAULT_CHARSET = 1


  Private Declare Function OleTranslateColor Lib ″OLEPRO32.DLL″ (ByVal OLE_COLOR As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long


  Private Const CLR_INVALID = -1


  Private m_picThis As PictureBox


  Private m_sCaption As String


  Private m_bRGBStart(1 To 3) As Integer


  Private m_oStartColor As OLE_COLOR


  Private m_bRGBEnd(1 To 3) As Integer


  Private m_oEndColor As OLE_COLOR ’api声明结束


  ’以下代码建立建立类模块的出入口函数


  Public Property Let Caption(ByVal sCaption As String) ’


  m_sCaption = sCaption


  End Property


  Public Property Get Caption() As String ’标题栏文字


  Caption = m_sCaption


  End Property


  Public Property Let DrawingObject(ByRef picThis As PictureBox)‘指定目标图片


  Set m_picThis = picThis


  End Property


  Public Property Get StartColor() As OLE_COLOR ‘StartColor = m_oStartColor


  End Property


  Public Property Let StartColor(ByVal oColor As OLE_COLOR) ‘指定前段颜色


  Dim lColor As Long


  If (m_oStartColor &lt;&gt; oColor) Then


  m_oStartColor = oColor


  OleTranslateColor oColor, 0, lColor


  m_bRGBStart(1) = lColor And &HFF&


  m_bRGBStart(2) = ((lColor And &HFF00&) \ &H100)


  m_bRGBStart(3) = ((lColor And &HFF0000) \ &H10000)


  If Not (m_picThis Is Nothing) Then


  Draw


  End If


  End If


  End Property


  Public Property Get EndColor() As OLE_COLOR


  EndColor = m_oEndColor


  End Property


  Public Property Let EndColor(ByVal oColor As OLE_COLOR) ‘指定后段颜色


  Dim lColor As Long


  If (m_oEndColor &lt;&gt; oColor) Then


  m_oEndColor = oColor


  OleTranslateColor oColor, 0, lColor


  m_bRGBEnd(1) = lColor And &HFF&


  m_bRGBEnd(2) = ((lColor And &HFF00&) \ &H100)


  m_bRGBEnd(3) = ((lColor And &HFF0000) \ &H10000)


  If Not (m_picThis Is Nothing) Then


  Draw


  End If


  End If


  End Property


  Public Sub Draw() ‘画背景颜色


  Dim lHeight As Long, lWidth As Long


  Dim lYStep As Long


  Dim lY As Long


  Dim bRGB(1 To 3) As Integer


  Dim tLF As LOGFONT


  Dim hFnt As Long


  Dim hFntOld As Long


  Dim lR As Long


  Dim rct As RECT


  Dim hBr As Long


  Dim hDC As Long


  Dim dR(1 To 3) As Double


  On Error GoTo DrawError


  hDC = m_picThis.hDC


  lHeight = m_picThis.Height \ Screen.TwipsPerPixelY


  rct.Right = m_picThis.Width \ Screen.TwipsPerPixelY


  lYStep = lHeight \ 255


  If (lYStep = 0) Then


  lYStep = 1


  End If


  rct.Bottom = lHeight


  bRGB(1) = m_bRGBStart(1)


  bRGB(2) = m_bRGBStart(2)


  bRGB(3) = m_bRGBStart(3)


  dR(1) = m_bRGBEnd(1) - m_bRGBStart(1)


  dR(2) = m_bRGBEnd(2) - m_bRGBStart(2)


  dR(3) = m_bRGBEnd(3) - m_bRGBStart(3)


  For lY = lHeight To 0 Step -lYStep


  rct.tOp = rct.Bottom - lYStep


  hBr = CreateSolidBrush((bRGB(3) * &H10000 + bRGB(2) * &H100& + bRGB(1)))


  FillRect hDC, rct, hBr


  DeleteObject hBr


  rct.Bottom = rct.tOp


  bRGB(1) = m_bRGBStart(1) + dR(1) * (lHeight - lY) / lHeight


  bRGB(2) = m_bRGBStart(2) + dR(2) * (lHeight - lY) / lHeight


  bRGB(3) = m_bRGBStart(3) + dR(3) * (lHeight - lY) / lHeight


  Next lY


  pOLEFontToLogFont m_picThis.Font, hDC, tLF


  tLF.lfEscapement = 900


  hFnt = CreateFontIndirect(tLF)


  If (hFnt &lt;&gt; 0) Then


  hFntOld = SelectObject(hDC, hFnt)


  lR = TextOut(hDC, 0, lHeight - 16, m_sCaption, Len(m_sCaption))


  SelectObject hDC, hFntOld


  DeleteObject hFnt


  End If


  m_picThis.Refresh


  Exit Sub


  DrawError:


  Debug.Print ″Problem: ″ & Err.Description


  End Sub


  Private Sub pOLEFontToLogFont(fntThis As StdFont, hDC As Long, tLF As LOGFONT) ‘文字字体


  Dim sFont As String


  Dim iChar As Integer


  With tLF


  sFont = fntThis.Name


  For iChar = 1 To Len(sFont)


  .lfFaceName(iChar - 1) =CByte(Asc(Mid$(sFont, iChar, 1)))


  Next iChar


  .lfHeight = -MulDiv((fntThis.Size), (GetDeviceCaps(hDC, LOGPIXELSY)), 72)


  .lfItalic = fntThis.Italic


  If (fntThis.Bold) Then


  .lfWeight = FW_BOLD


  Else


  .lfWeight = FW_NORMAL


  End If


  .lfUnderline = fntThis.Underline


  .lfStrikeOut = fntThis.Strikethrough


  End With


  End Sub


  Private Sub Class_Initialize()


  StartColor = &H0


  EndColor = vbButtonFace


  End Sub ‘模块定义结束


  调试、运行。  </PRE>

redking 发表于 2006-1-9 16:02

<PRE>用VB尝试新的界面风格
作者:宠大
随着微软Windows产品风格的不断演进,各应用软件厂商也在跟进,但经常是主流的开发工具跟不上节奏,这时往往就需要用一些辅助的工具来编制那精美的界面了。本文只是略谈一点这方面的感受,举两个小工具的例子。

用ActiveBar制作Office97风格的菜单与工具条

在微软的最新97风格(以Office97、VisualStudio97和InternetExplorer为代表)中,出现了新的菜单与工具条,它们都具有浮起效果,菜单有了图标,并且它们实际上都可以是一些独立窗口,拖到程序主窗口的最上方,便被吸了过去,成为了菜单或工具条。

ActiveBar是DataDynamics公司的产品,安装后,你可以在VB的Components中找到ActiveBarControl一项,将它添加到你的项目中,便可以使用了。这个控件的使用有点特别,在“属性”中除了颜色、字体等常规内容外,找不到什么实质性的东西,回去看看95的“开始”菜单,安装时它在那里留了一个叫ActiveBarDesigner的应用程序,可是在这个Designer里设计的界面怎么才能让VB接受呢?原来当你在VB中“画”该控件时,点击鼠标右键,会发现在Properties的位置有一项Designer,点击之,就可以在VB中以OLE嵌入的方式打开那个ActiveBarDesigner了,在这里设计的效果,在VB中Run的时候就可以看到了。

用ctListBar制作IE4的List

在微软1997年的Web产品(IE4和FrontPage98)中,使用了一种新的List,以或大或小的图标和漂亮的背景取代的白色方框里面被选的蓝色条条,并且可以在一个控件中实现几个List的功能(通过分页来实现)。

为了做出这种精美(与原先蓝白条的List相比,它确实太美了)的List,Gamesman公司开发了这个名为ctListBar的控件,将它调入你的项目,在属性的Custom项中,可以设置它的绝大部分特性,比如横竖、图标的大小、按钮的突起或凹陷、卷轴等。其中对最终的视觉效果起决定性作用的是BackImage和GradientFill,BackImage是Picture下面的属性,用来设置该List的底图(其实这个List的美丽大部分来自底图),或者更朴素一点的方法,不设底图,而是选用GradientFill(它是General里的一个可选项),它会做一个色彩渐变的效果,至于渐变的具体色彩,你可以通过在Color中指定GradColorFrom和GradColorTo来设置,这样只需要设置三个属性,你就可以得到与IE4和FrontPage98一样精美的List了。当然,所有这些属性都是可以在运行时修改的,ctListBar的帮助文件和例子程序中给出了详细的说明。

用TrayICON制作95状态栏里的图标

在Windows95中,有些应用程序需要在95的状态栏中登录一个图标,这在VC++中并不难实现,但VB中却没有提供相应的控件,为此,NikhilKothari制作了这个TrayICON控件,利用它,VB的程序员可以轻易地在95的状态栏中登录图标。

打开TrayICON附带的例子程序,看到它的几个主要特性:TrayIconl.Visible(是否在状态栏中可见)、TrayIconl.MouseMoveEvents(是否跟踪鼠标在状态栏里的移动)、TrayIconl.ToolTip(浮动的提示信息)、TrayIcon1.AutoUpdate(是否自动更新图标)和非常简明的方法:ShowICON、HideICON等,关于这些特性和方法的代码,可以在例子程序中找到,且都非常简单(看看ShowICON的代码,只是一句successΚTrayIconl.ShowIcon而已)。

有了TrayICON控件,用VB写95状态栏登录的程序再也不难了。

采用Web风格

随着Internet的日益流行,很多的软件厂商都开始尝试在应用软件中采用Web风格,我个人认为Web风格会在应用软件中逐渐流行———既然以后所有的95上都会安装浏览器(不管是IE还是Communicator),并且HTML会是最流行的超文本格式,为什么软件中的超文本不能用Web风格呢?———至少我认为Web风格的帮助会比RTF编译过去的HLP文件要灵活、美观得多。

在新的开发工具中,大多提供了现成的WebBrowser窗口例子程序(至少VB5和Delphi3是这样),VB5的用户只要在新建窗口时使用一下向导,要它建立一个Browser窗口就可以了(但是注意,这样默认的窗口是MDI子窗口,别忘了修改一下MDI属性)。如果你还在使用VB4(VB5在某些方面的BUG实在难以忍受,所以有时VB4反到显得成熟一些),是没法使用这个向导的,但这也不难,只要你安装一份前面提到的ActiveBar就可以了———它的另外一个例子程序就是一个WebBrowser,并且菜单和工具条还是Office97风格的,当然它需要微软的WebBrowser控件———不管你安装IE3和IE4,这个控件都会在VB中可用的(笔者第一次写WebBrowser就是这样写的,当时的IE3提供了WebBrowser控件,但没有任何的文档,不想在ActiveBar的例子中找到了答案)。

总之,VB程序员必须留心第三方控件(3DPartyControls)的最新发展,时时将最新的控件加入自己的程序中,这样才能跟上软件发展的最新潮流(不仅仅是界面的风格)。
</PRE>

redking 发表于 2006-1-9 16:02

<PRE>用VB建立字符界面的控制台程序


邓双成

一、概述
  即使是初学VB的人,对于如何用它来建立一个GUI界面的标准Windows应用程序,肯定也是胸有成竹;然而,对于如何用VB来编写字符界面的控制台程序(Console-Mode Applications),知道的人恐怕不多。有人甚至认为这是不可能的,因为VB对编写控制台程序并无内在的支持,在VB的“新建工程”对话框里没有“控制台程序”这一选项。实际上,利用Windows提供的应用程序编程接口(API),VB是能够建立控制台程序的。控制台程序与图形界面的标准Windows程序不同,它没有Windows程序所通行的窗口,其与用户的交互是基于字符界面,外观类似于“MS-DOS方式”,如图1所示。


图1 本文示例程序的运行结果

  同标准的Windows程序相比,控制台程序具有界面简单、占内存少、生成的可执行文件小的优点,因而在某些场合还有用武之地。

二、具体步骤
  由于VB对建立控制台程序并无内在支持,全部工作都是依靠调用API函数来完成,故首先要用VB建立一个新的“标准EXE”工程,并删除其默认窗体(Form1),添加一标准模块(Module1),将其改名为VBConsole.bas,后续的所有工作都是在此模块中完成的。
  下面按功能分类逐一介绍本文用到的API函数。
  1.创建和销毁控制台窗口(consol window)用VB创建控制台程序的第一步就是为VB程序创建一个console window,并在程序结束时销毁它。这分别用到AllocConsole和FreeConsole函数。
  Private Declare Function AllocConsole Lib "kernel32"() As Long
  功能:为VB程序创建一个 console window。
  Private Declare Function FreeConsole Lib "kernel32"() AS Long
  功能:销毁为VB程序创建的 console window。
  2.取得所建立的 console window 的句柄(Handle)
  DOS程序有三个标准文件:标准输入文件(stdin),标准输出文件(stdout),标准错误文件(siderr)。与此类似,控制台程序窗口有三个句柄:
  输入句柄(input handle) — 指向控制台程序的输入缓冲区
  输出句柄(output handle)、错误句柄(error handle)— 指向控制台程序的屏幕输出缓冲区
  在能够进行输入/输出操作之前,必须用 GetstdHandle 函数取得 console window 的这三个句柄。
  Private Declare Function GetStdHandle Lib "kernel32" (ByVal nStdHandle As Long) As Long
  功能:返回 console window 的三个句柄之一。
  说明:参数nStdHandle决定此函数返回的是哪一个句柄,它可以取如下值之一:
  Private Const STD_INPUT_HANDLE = -10&amp;   '返回 input handle
  Private Const TD_OUTPUT_HANDLE = - 11&amp;  '返回 output handle
  Private Const STD_ERROR_HANDLE = -12&amp;   '返回 error handle
  3.控制台输入/输出创建了 console window 并获得其 input/output handle 后,就可以利用WriteConsole和ReadConsole进行输入/输出了。
Private Declare Function WriteConsole Lib "kernel32" Alias "WriteConsoleA" _
(ByVal hConsoleoutput As Long,ByVal lpBuffer As Any, ByVal nNumberofCharsTowrite _
As Long, IpNumberofCharsWritten As Long, lpReserved As Any) As Long
  功能:向控制台窗口输出字符串。
  说明:hConsoleOutput—控制台的outputhandle。
     lpBuffer—要输出的字符串。
     nNumberOfCharsToWrite—要输出的字符串的长度。
     lpNumberofCharsWritten—实际输出的字符串的长度,可置为vbNull。
     lpReserved—保留,必须置为vbNul。
Private Declare Function ReadConsole Lib "kernel32" Alias "ReadConsoleA" _
(ByVal hConsoleInput As Long, ByVal lpBuffer As String, ByVal nNumberofCharsToRead _
As Long,lpNumberofCharsRead As Long, lpReserved As Any) As Long
  功能:从输入缓冲区输入字符串。
  说明:此函数是以块方式输入信息。在本文的示例中,只有用户按了Enter(回车)键后,此函数才返回。
  hConsoleInput—console window的input handle。
  lpBuffer—输入缓冲区地址。
  nNumberOfCharsToRead—输入缓冲区的长度。
  lpNumberOfCharsRead—实际读入的字符数,可置为vbNull。
  lpReserved—保留,必须置为vbNull。
Private Declare Function SetConsoleMode Lib "kernel32" (ByVal hConsoleHandle _
As Long, dwMode As Long) As Long
  功能:设置控制台输入缓冲区的输人模式或屏幕输出缓冲区的输出模式。
  说明:在用 ReadConsole和 WriteConsole函数行输入/输出前,要用此函数设置好输入/输出模式。
  hConsoleHandle—console window的Input handle或output handle。
  dwMode是要设置的输入或输出模式值。hConsoleHandle是Input handle时, dwMode可取如下值的组合:
  Private Const ENABLE_LINE_INPUT = &amp;H2
  Private Const ENABLE_ECHO_INPUT = &amp;H4
  Private Const ENABLE_MOUSE_INPUT = &amp;H10
  Private Const ENABLE_PROCESSED_INPUT = &amp;H1
  Private Const ENABLE_WINDOW_INPUT = &amp;H8
  当 hConsoleHandle 是 output handle 时,dwMode可取如下值的组合:
  Private Const ENABLE_PROCESSED_OUTPUT = &amp;H1
  Private Const ENABLE_WRAP_AT_EOL_OUTPUT = &amp;H2
  这些取值的具体意义,请参见 WINDOWS SDK 文档,此处不再详述。
  注意:VB的API浏览器对WriteConsole和ReadConsole两函数的声明是不对的。尽管lpBuffer为长指针,它仍然应为传值调用,这是由于VB和API对字符串的存储和处理方式不一致造成的。
  4.其他API函数
  有了l、2、3所述的API函数,就可以创建一个基本的控制台程序了。当然,我们还可以用如下的API函数再“修饰”一下呆板的控制台窗口。
Private Declare Function SetConsoleTitle_Lib "kernel32"Alias "SetConsoleTitleA" _
(ByVal lpConsoleTitle As String) As Long
  功能:设置控制台窗口的标题。
  说明:lpConsoeTitle—要设置的窗口标题(字符串)。
Private Declare Functon SetConsoleTextAttribute Lib "hernel32" _
(ByVal hConsoleOutput As Long, ByVal wAttributes As Long) As Long
  功能:设置要在控制台窗口输出的字符的前景色和背景色
  说明: hConsoleOutput—控制台窗口的output handle
     wAttributes—决定了console window的前景色和背景色,可以是如下数值的组合:
Private Const FOREGROUND_BLUE = &amp;H1 '前景:蓝
Private Const FOREGROUND_GREEN = &amp;H2 '前景:绿
Private Const FOREGROUND_RED = &amp;H4 '前恐;红
Private Const FOREGROUND_INTENSITY = &amp;H8 '前景:高亮度
Private Const BACKGROUND_BLUE = &amp;H10 '背景:蓝
Private Const BACKGROUND_GREEN = &amp;H20 '背景:绿
Private Const BACKGROUND_RED = &amp;H40 '背景:红
Private Const BACKGROUND_INTENSITY = &amp;H80 '背景:高亮度
  例如,要设置前景色为黄色,可定义如下的常量并将其赋值给 wAttributes。
Private Const FOREGROUND_YELLOW = FOREGROUND_RED Or FOREGROUND_GREEN

三、程序清单
  示例程序将创建一个控制台窗口,并输出提示信息,要用户输入自己的名字。用户输入名字后,程序输出问候信息,并等待用户按键返回。本文的示例程序在VB5.0中文版下调试通过。
Option Explicit
' API函数声明
Private Declare Function AllocConsole Lib "kernel32" () As Long
Private Declare Function FreeConsole Lib "kernel32" () As Long
Private Declare Function GetStdHandle Lib "kernel32" (ByVal nStdHandle As Long) As Long
Private Declare Function ReadConsole Lib "kernel32" Alias "ReadConsoleA" _
(ByVal hConsoleInput As Long, ByVal lpBuffer As String, ByVal nNumberOfCharsToRead _
As Long, lpNumherOfCharsRead As Long, lpReserved As Any) As Long
Private Declare Function WriteConsole Lib "kernel32" Alias "WriteConsoleA" _
(ByVal hConsoleOutput As Long, ByVal lpBuffer As Any, ByVal nNumberOfCharsToWrite _
As Long, lpNumberOfCharsWritten As Long, lpReserved As Any) As Long
Private Declare Function SetConsoleMode Lib "kernel32" (ByVal hConsoleOutput As Long, _
dwMode As Long) As Long
Private Declare Function SetConsoleTitle Lib "kernel32" Alias "SetConsoleTitleA" _
(ByVal lpConsoleTitle As String) As Long
Private Declare Function SetConsoleTextAttribute Lib "kernel32" _
(ByVal hConsoleOutput As Long, ByVal wAttributes As Long) As Long
'定义API函数中用到的所有常量
'GetStdHandle函数的 nStdHandle参数的取值
Private Const STD_INPUT_HANDLE = -10&amp;
Private Const STD_OUTPUT_HANDLE = -11&amp;
Private Const STD_ERROR_HANDLE = -12&amp;
'SetConsoleTextAttribute函数的wAttributes参数的取值(按RGB方式组合)
Private Const FOREGROUND_bLUE = &amp;H1
Private Const FOREGROUND_GREEN = &amp;H2
Private Const FOREGROUND_RED = &amp;H4
Private Const FOREGROUND_INTENSITY = &amp;H8
Private Const BACKGROUND_BLUE = &amp;H10
Private Const BACKGROUND_GREEN = &amp;H20
Private Const BACKGROUND_RED = &amp;H40
Private Const BACKGROUND_INTENSITY = &amp;H80
'SetConsoleMode的输入模式
Private Const ENABLE_LINE_INPUT = &amp;H2
Private Const ENABLE_ECHO_INPUT = &amp;H4
Private Const ENABLE_MOUSE_INPUT = &amp;H10
Private Const ENABLE_PROCESSED_INPUT = &amp;H1
Private Const ENABLE_WINDOW_INPUT = &amp;H8
'SetConsoleMode的输出模式
Private Const ENABLE_PROCESSED_OUTPUT = &amp;H1
Private Const ENABLE_WRAP_AT_EOL_OUTPUT = &amp;H2
Private hConsoleIn As Long '控制台窗口的 input handle
Private hConsoleOut As Long '控制台窗口的output handle
Private hConsoleErr As Long '控制台窗口的error handle
'主程序
Private Sub Main()
 Dim szUserInput As String
 AllocConsole '创建 console window
 SetConsoleTitle "VB控制台应用程序"
 '设置console window的标题
 '取得console window的三个句柄
 hConsoleIn = GetStdHandle(STD_INPUT_HANDLE)
 hConsoleOut = GetStdHandle(STD_OUTPUT_HANDLE)
 hConsoleErr = GetStdHandle(STD_ERROR_HANDLE)
 SetConsoleTextAttribute hConsoleOut, FOREGROUND_GREEN Or FOREGROUND_INTENSITY
    '前景:亮绿;背景:黑
 ConsolePrint "What's your name?"
 szUserInput = ConsoleRead()
 If Not szUserInput = vbNullString Then
  ConsolePrint "Hello, " &amp; szUserInput &amp; "!" &amp; vbCrLf
 Else
  ConsolePrint "You don't have a name?" &amp; vbCrLf
 End If
 ConsolePrint vbCrLf &amp; "Press enter to exit!"
 Call ConsoleRead
 FreeConsole '销毁 console window
End Sub

'程序中用到的子函数
Private Sub ConsolePrint(szOut As String)
 WriteConsole hConsoleOut, szOut, Len(szOut), vbNull, vbNull
End Sub

Private Function ConsoleRead() As String
 Dim sUserInput As String * 256
 Call ReadConsole(hConsoleIn, sUserInput, Len(sUserInput), vbNull, vbNull)
     '截掉字符串结尾的&amp;H00和回车、换行符
 ConsoleRead = Left$(sUserInput, InStr(sUserInput, Chr$(0)) - 3)
End Function
 
  </PRE>

redking 发表于 2006-1-9 16:03

<PRE>用VB快速读取TextBox第N行的数据
TextBox 是以 vbCr+vbLf 为分行符号, 如果我们要逐一读取 TextBox 每一行, 无非是寻找 vbCr+vbLf 的所在位置, 然后取出每一行的字串, 不过这个方法不快,而且如果我们要读取第 N 行数据,还是要从第 1、2、…N-1 行逐一读起,实在麻烦。 还好 Windows API 提供有读取 TextBox 第 N 行的功能, 细节如下:

1、API 的声明:

Public Const EM_GETLINE = &amp;HC4
Public Const EM_LINELENGTH = &amp;HC1
Public Const EM_LINEINDEX = &amp;HBB

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Declare Sub RtlMoveMemory Lib "KERNEL32" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)

2. 程序范例:


Sub TB_GetLine(ByVal hWnd As Long, ByVal whichLine As Long, Line As String)

Dim length As Long, bArr() As Byte, bArr2() As Byte, lc As Long

lc = SendMessage(hWnd, EM_LINEINDEX, whichLine, ByVal 0&amp;)

length = SendMessage(hWnd, EM_LINELENGTH, lc, ByVal 0&amp;)

If length &gt; 0 Then
ReDim bArr(length + 1) As Byte,bArr2(length - 1) As Byte
Call RtlMoveMemory(bArr(0), length, 2) '准备一个存储器,传递消息之前先在存储器的前两个字节填入存储器的长度
Call SendMessage(hWnd, EM_GETLINE,whichLine, bArr(0))
Call RtlMoveMemory(bArr2(0), bArr(0), length)
Line = StrConv(bArr2, vbUnicode)
Else
Line = ""
End If

End Sub


' 假设要读取 Text1 第 5 行的数据

Dim S As String

Call TB_GetLine( Text1.hWnd, 5, S )

' 传回值 S 即等于第 5 行的数据

( 注:TextBox 的行次是从 0 起算。)

站长在去掉有关bArr2的定义后,并将Line=Strconv(bArr2,vbUnicode)改为Line=StrConv(bArr,vbUnicode)发现程序照常运行,似乎bArr2在本程序中是多余的。不知哪位大虾能告知本人bArr2在这里的作用。
</PRE>

redking 发表于 2006-1-9 16:03

<PRE>用VB快速读取TextBox第N行的数据
TextBox 是以 vbCr+vbLf 为分行符号, 如果我们要逐一读取 TextBox 每一行, 无非是寻找 vbCr+vbLf 的所在位置, 然后取出每一行的字串, 不过这个方法不快,而且如果我们要读取第 N 行数据,还是要从第 1、2、…N-1 行逐一读起,实在麻烦。 还好 Windows API 提供有读取 TextBox 第 N 行的功能, 细节如下:

1、API 的声明:

Public Const EM_GETLINE = &amp;HC4
Public Const EM_LINELENGTH = &amp;HC1
Public Const EM_LINEINDEX = &amp;HBB

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Declare Sub RtlMoveMemory Lib "KERNEL32" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)

2. 程序范例:


Sub TB_GetLine(ByVal hWnd As Long, ByVal whichLine As Long, Line As String)

Dim length As Long, bArr() As Byte, bArr2() As Byte, lc As Long

lc = SendMessage(hWnd, EM_LINEINDEX, whichLine, ByVal 0&amp;)

length = SendMessage(hWnd, EM_LINELENGTH, lc, ByVal 0&amp;)

If length &gt; 0 Then
ReDim bArr(length + 1) As Byte,bArr2(length - 1) As Byte
Call RtlMoveMemory(bArr(0), length, 2) '准备一个存储器,传递消息之前先在存储器的前两个字节填入存储器的长度
Call SendMessage(hWnd, EM_GETLINE,whichLine, bArr(0))
Call RtlMoveMemory(bArr2(0), bArr(0), length)
Line = StrConv(bArr2, vbUnicode)
Else
Line = ""
End If

End Sub


' 假设要读取 Text1 第 5 行的数据

Dim S As String

Call TB_GetLine( Text1.hWnd, 5, S )

' 传回值 S 即等于第 5 行的数据

( 注:TextBox 的行次是从 0 起算。)

站长在去掉有关bArr2的定义后,并将Line=Strconv(bArr2,vbUnicode)改为Line=StrConv(bArr,vbUnicode)发现程序照常运行,似乎bArr2在本程序中是多余的。不知哪位大虾能告知本人bArr2在这里的作用。
</PRE>

redking 发表于 2006-1-9 16:04

<PRE>用VB 设 计VCD 播 放 器
成 都
傅 能 红

---- 该 程 序 通 过VB 的 多 媒 体 控 件MCI32.OCX 可 以 打 开MPEG 压 缩 文 件( 如VCD2.0 版 的.DAT 文 件) 来 实 现 一 个VCD 播 放 器 的 设 计

---- 首 先 必 须 确 保 在 你 的Windows 系 统 中SYSTEM.INI 文 件 关 于[MCI] 中 需 有MPEGVideo 项( 一 般Windows 95 和Windows 98 中 均 有 此 项) 。

---- 其 次 在VB 中 建 立 一 个 新 窗 口, 加 入 多 媒 体 部 件Microsoft Multimedia Control 5.0( 位 于C:\Windows\System\MCI32.OCX), 以 及 对 话 框 部 件 Microsoft Common Dialog Control 5.0( 位 于C:\Windows\System\COMMONDLG32.OCX), 将MCI 控 件 拖 放 至 窗 体Form 上, 调 整 其 大 小, 并 将 窗 体 的 大 小 也 调 整 为 与 其 同 样 大 小; 将 其 九 个 按 钮( 从 左 至 右 为:Prev、Next、Play、Pause、Back、Step、Stop、Record 和 Eject) 中 的Record 按 钮 的Visible 属 性 设 为False, 其 余 按 钮 中 的Visible 属 性 和Enabled 属 性 设 为True , 以 上 按 钮 的 设 置 可 通 过MMControl 的 属 性 栏 内" 自 定 义" 项 来 设 置。 对 话 框 控 件 的DefaultExt 属 性 设 为.DAT, DialogTitle 属 性 设 为" 打 开 多 媒 体 文 件", Filter 属 性 设 为"*.DAT, *.WAV", InitDir 属 性 设 为"G:\MPEGAV"( 假 设 光 驱 盘 符 为G) 。

---- 源 代 码 如 下:

Option Explicit

Private Sub Form_Load()
  Dim Response As Integer
  MMControl1.DeviceType = "MPEGVideo"
  CommonDialog1.ShowOpen   
  '通过对话框选择不同的VCD文件
  MMControl1.filename = CommonDialog1.filename
   '选定要播放的文件
  MMControl1.Command = "Open"
  MMControl1.Command = "Play"
  
End Sub

Private Sub Form_Unload(Cancel As Integer)
  MMControl1.Command = "close"
End Sub

Private Sub MMControl1_BackClick(Cancel As Integer)
'对Back按钮的功能改进
  Dim i As Integer
  i = MMControl1.Position - 100  
  '数值100为后退量,可适当调整
  If i &lt; 0 Then
    MMControl1.From = 0
  Else
    MMControl1.From = i
  End If
  MMControl1.Command = "Play"
  
End Sub

Private Sub MMControl1_StepClick(Cancel As Integer)
'对Step按钮的功能改进
  Dim j As Integer
  j = MMControl1.Position + 100
  '数值100为前进量,可适当调整
  If j &gt; MMControl1.Length Then
    MMControl1.From = MMControl1.Length
  Else
    MMControl1.From = j
  End If
  MMControl1.Command = "Play"
End Sub
---- MCI 控 件 还 有 很 多 属 性, 如 画 面 播 放 位 置hWndDisplay 属 性 等 等, 大 家 可 参 阅 相 关 资 料 自 行 摸 索。

---- 调 整 好 窗 体 的 标 题、 图 标、 颜 色 等, 然 后 编 译 成 .EXE 文 件, 你 就 可 以 在Windows 下 拥 有 自 己 的VCD 播 放 器 了。
</PRE>

redking 发表于 2006-1-9 16:04

<PRE>用VB设计更好的用户界面
  有时在一个窗口中出现较多的控制件时,如果能向导式地建议用户下一步该做什么,不失为上策。在Visual Basic的程序设计中,我们可以使用语句:object.SetFaocus使我们希望的控件得到输入焦点,举个例子:在Form1中我们加入一个按钮Command1和一个文本输入Text1,双击按钮控件,然后键入如下代码:text1.SetFocus

  再按F5运行程序,您就会看到一单击按钮,文本框会立即取得输入焦点。另外,我们还可以使用语句:Sendkeys "{TAB}"使下一个控件获得焦点,但我们需要在设计时确定各控件的Index值。(在Properties窗口中)让控件自己感知自己的工作已完成,而主动将焦点让出,会使用户觉得应用程序很聪明,也减少了用户出错的机会。
  可是当焦点切换的两个控件相隔有一定距离时,上述的方法有时也不足以引起用户的注意,那么一种好的解决方法是将鼠标箭头也移到控件上。可惜,VB并不支持鼠标移动,那我们就求助API函数,API函数SetCursorPos可让我们如愿。
  下面是子程序MoveCursorOn,它可让鼠标移动到指定控件上方。

下列代码请放在declarations段中:
Type PoinTAPI
x As Integer
y As Integer
End Type
Declare Sub SetCursorPos Lib "User"(Byval x As Integer,Byval y As Integer)
Declare Sub ClientToScreen Lib "User"(Byval hwnd As Integer,IpPoint As PointAPI)
Declare Function GetParent Lib "User"(Byval hwnd As Integer)As Integer

然后建立一个新的子程序(ALT+N→N→键入子程序名MoveCursorOn),下面是子程序的代码:
Sub MoveCursorOn(source As Control)
   Dim Pt As PoinTAPI
   Dim hparent As Integer
   p.x=(Source.Left+Source.Width/2)/Screen.Twipsperpixel)
   p.y=(Source.Top+Source.Height/2)/Screen.Twipsperpixel)
   hparent=GetParent(source.hwnd)
   ClientToScreen hparent pt
   SetCursorPos pt.x pt.y
   End Sub

使用该子程序很容易,例如我们想把鼠标移动到按钮Command1上,就可使用语句Move Cursor On Command1
您会看到鼠标箭头已经指着按钮Command1。
  需要说明的是,千万不要滥用该子程序。让鼠标自己满屏乱飞,我们的用户会感到失去对应用程序的控制,这是违反我们的初衷的。
在有数个输入框的窗口中(这在数据库应用程序中是很典型的),当用户完成第一个输入框的输入后,总爱习惯性的加一个回车,希望输入焦点落到下一个输入框中(DOS中大多数应用程序是如此),可往往事与愿违,这一回车却触发了拥有Default特性的按钮,结果不是关闭了当前窗口就是又蹦出另一窗口。用户睁大眼睛看着屏幕,"咦?!我到底做了什么?”这是Windows新用户经常遇到的事情。解决它其实很容易,只需在输入框的KeyPress事件中加入如下代码:

IF KeyASCII=13 Then
  KeyASCII=0
  Sendkeys "{TAB}"
END IF

这样,当用户在这个输入框中键入Enter时,就象键入TAB键时,焦点被移到下一控件上。但需注意,这种方法不适用于多行的TextBox,即TextBox的MultiLine特性设为True时,因为这时的回车键是起换行的作用。  
</PRE>

redking 发表于 2006-1-9 16:04

<PRE>用VB设计聚焦框程序


季昭君

  什么是聚焦框?在Windows中是这样解释的:当某个按钮被按下或某个控件正在使用时,由一个长方形的虚线框聚焦在此按钮或控件上来提示用户它正起作用。但是并非所有的控件在任何时候都能得到焦点(即得到聚焦框),有时我们在日常的编程中也许会用到它,用来提示用户一些必要的信息。这时你可以这样做:
  说明: 在以下程序中可以使Picture控件得到聚焦框,且程序调用API函数来完成。
  首先,在FORM1上新建一个Picture1和一个Command1,然后输入以下代码:

  Private Declare Function DrawFocusRect Lib "user32" _
    (ByVal hdc As Long, lpRect As RECT) As Long
  Private Type RECT
    X1 As Long
    Y1 As Long
    X2 As Long
    Y2 As Long
  End Type
  Dim lpRect As RECT '在通用中声明调用API函数
  Private Sub Form_Load()
    Form1.WindowState = 2 '最大化窗口
    Picture1.Picture = LoadPicture("C:\BMP\1.BMP") '请读者根据自己选择图片
    Command1.Caption ="设置聚焦框"
  End Sub
  Private Sub Form_Activate()
    Picture1.Move (Form1.ScaleWidth - Picture1.ScaleWidth) / 2, _
        (Form1.ScaleHeight - Picture1.ScaleHeight) /2 '使Picture1居中显示
  End Sub
  Private Sub Command1_Click()
    Dim DENG As Long
    lpRect.X1 = Picture1.Left - 10
    lpRect.Y1 = Picture1.Top - 10
    lpRect.X2 = lpRect.X1 + Picture1.Width + 20
    lpRect.Y2 = lpRect.Y1 + Picture1.Height + 20
    DENG = DrawFocusRect(hdc, lpRect)
  End Sub

  OK,大功告成,按F5运行,通过单击按钮Command1就可以实现Picture1控件被聚焦! 当然你也可以作适当调整,使它符合你个人的需要。


</PRE>

sandhiller 发表于 2006-1-9 17:23

<P>楼主,整理为一个文件,利国利民</P>

redking 发表于 2006-1-10 09:10

<PRE>用VB实现“ICQ”式的启动欢迎画面


广西 高 罡
  第一次运行,或通过运行程序的方式来启动ICQ时,随着一声火车的长鸣,我们都能看到一朵背景为透空的大花,这就是ICQ独特的欢迎画面!通常,我们都是用一整个带图形及文字的窗体来做为欢迎画面的。我们要如何去做才能实现类ICQ的欢迎画面呢?这看起来像是件十分复杂的工作,其实,利用了强大的API函数,事情就会变得非常的简单。出于简单化的考虑,我使用VB6.0简体中文企业版来完成这一例程。
  首先要准备好做为欢迎画面所需要的图片,然后对图片进行简单的处理,把需要透空的地方填上纯白色(255,255,255),然后保存为*.bmp文件,这用PhotoShop可以很容易地实现。需要注意的是,图片必须为“索引色”模式,如果不是就需用PhotoShop来修改,否则不能实现透空效果。
  先建立一个标准EXE工程,在窗体上文稿放置一个Picture控件,控件名为Picture1,和一个Timer控件,控件名为Timer1,Interval属性设置为2000。
  原程序如下:

  Option Explicit
  '定义获取桌面HDC的api函数
  Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
  '定义TransparentBlt函数
  '实现图片的透空效果需要用上API函数:TransparentBlt,这个函数功能十分强大,而且使用方便,但不幸的
  '是VB自带的API浏览器居然把它的漏掉了,所以我们只有采用人工输入的方法了
  Private Declare Function TransparentBlt Lib "msimg32.dll" _
   (ByVal hdcDest As Long, _
   ByVal nXOriginDest As Long, _
   ByVal nYOriginDest As Long, _
   ByVal nWidthDest As Long, _
   ByVal nHeightDest As Long, _
   ByVal hdcSrc As Long, _
   ByVal nXOriginSrc As Long, _
   ByVal nYOriginSrc As Long, _
   ByVal nWidthSrc As Long, _
   ByVal nHeightSrc As Long, _
   ByVal crTransparent As Long) As Long
  '其中,hdcDest为目标地的HDC,nXOriginDEst和nYoriginDest分别为目标图像的起始点坐标,nWidthDesk和nHeightDest分别为目标图像的宽度和高度。与之相应的hdcSrc、nXOriginSrc、nyOriginSrc、nWidthSrc、nHeightSrc分别为原图的HDC、原图的起始X、Y坐标、原图和宽度和长度,crTransparent为需要设置成透空的颜色的RGB值。
  '定义用于恢复桌面的函数
  Private Declare Function InvalidateRectAsAny Lib "user32" Alias _
    "InvalidateRect" (ByVal hwnd As Long, lpRect As Any, _
    ByVal bErase As Long) As Long

  Private Sub Form_Load()
   Me.Hide
   Dim Pic As Long
   Dim w As Long
   Dim h As Long
   Dim x As Long
   Dim sx, sy
  Picture1.AutoRedraw = True
  '获取桌面的HDC
  x = GetDC(0)
  '计算桌面的宽度和高度
   sx = Screen.Width \ Screen.TwipsPerPixelX
   sy = Screen.Height \ Screen.TwipsPerPixelY
  '计算图像的宽度和高度
  w = Picture1.ScaleX(Picture1.Picture.Width, 8, vbPixels)
  h = Picture1.ScaleY(Picture1.Picture.Height, 8, vbPixels)
  
  picture1.picture=loadpicture("图像文件的完整文件名称")
  
  '使透空的图像显示在桌面的中央
   Pic = TransparentBlt(x, _
   sx / 2 - w / 2, _
   sy / 2 - h / 2, _
   w, _
   h, _
   Picture1.hDC, _
   0, _
   0, _
   w, _
   h, _
   RGB(255, 255, 255))
  End Sub
  Private Sub Timer1_Timer()
  '两秒钟后恢复桌面
  InvalidateRectAsAny 0, ByVal 0&, True
  Load 自制程序的主窗体名
  Timer1.Enabled = False
  End Sub
  需要注意的是程序完成后如果直接在VB环境下运行有可能会出现透空图像一闪而过的现象,这并不是你的错,只要把程序编译成*.exe的文件后运行一切都会正常的。

</PRE>

redking 发表于 2006-1-10 09:10

<PRE>用VB实现“百叶窗”的图形特效
在Powerpoint这样的软件中,各种各样的图形特效层出不穷,其中“百叶窗”的切换效果尤为新颖奇特。在VB中实现这样的图形特效十分简单方便。其方法是调用WINDOWS的API函数Bitblt。BitBlt函数就类似于C语言中的getimage、putimage两个函数的组合运用。BitBlt原意是“Bit Block Transfer”,其主要用途是位图的复制。用BitBlt函数显示图形特效,其原理十分简单,制作时先在表单中绘制两个图片框,将图片存入一个图片框,同时将另一个图片框设为空,然后调用BitBlt函数将第一个图片框中的图形一部分一部分地复制到第二个图片框中,这样就可以实现千奇百怪的图形特效。其步骤如下:
在VB环境中新建一个窗体,绘制两个图片框picSour和picDest,两个命令按钮cmdShow和cmdExit。首先在窗体的通用过程中声明BitBlt函数即所需要的常量名,在载入窗体同时在picSour中载入图片,在按钮cmdShow的事件中调用BitBlt函数。程序如下:
API函数声明:
Declare Function BitBlt Lib″GDI″(ByVal hDestDC As Integer,ByVal X As Integer,ByVal Y As Integer,ByVal nWidth AS Integer,ByVal nHeight As Integer,ByVal hSrcDC As Integer,ByVal xSrc As Integer,ByVal ySrc As Integer,ByVal dwRop As Long)As Integer
Const COPY-PUT=&HCC0020′BitBlt的15种算法之一,表示直接拷贝
载入图片:
Sub Form-Load()
picsour.Picture=LoadPicture(″c:\windows\LEAVES.bmp″)
picsour.ScaleMode=3′以象素为单位
End Sub
显示“百叶窗”的切换效果:
Sub Comshow-Click()
H%=picsour.ScaleHeight
W%=picsour.ScaleWidth
scanlines=4
For I=0 To(scanlines-1)
For j=I To H% Step scanlines
s%=BitBlt%(picdest.hDC,0,j,W%,1,picsour.hDC,0,j,copy-Put)
delay 500′延时
Next j
Next I
End Sub
其中delay是一个通用子过程,用于延时,以便于能看清楚切换效果。代码如下:
Sub delay(delaytime As Integer)
For I=1 To delaytime
Next I
End Sub

</PRE>

redking 发表于 2006-1-10 09:12

<PRE>用VB实现全屏幕图形界面及动态功能提示
王华 张晖 黄润发
一、 全屏幕图形界面设计
图形界面是现代软件中人机交互的主要手段。为了追求界面的统一和美观,在
软件开放过程中,图形界面大多采用全屏幕构图方式。这是通过将窗体的边框设置
为无边框(BorderStyle=None),将窗体显示模式设置为极大化(WindowState=
Maximized)来实现的。
当一个窗体界面的设计中要容纳多张图片和多个控制时,将出现窗体显示速度
明显变慢的现象,严重影响了程序运行的流畅性。为了解决这一问题,在开放过程
中,采用了一种将【界面设计窗体】与【功能实现窗体】分开处理的方法。
在【界面设计窗体】中,首先按功能的需要和界面设计的创意,将所需的大量
图片和控制在屏幕上安排好,选择美观的字体、颜色、线型,对屏幕界面进行设计、
修饰加工;然后在其全屏幕运行的状态下,利用剪贴技术,将这一设计完成的图形
界面全屏幕复制到剪贴板上;接着将这一屏幕映象作为一张图片粘贴在【功能实现
窗体】的背景上。这样,从外观上看,两个窗体的形状完全相同,而在屏幕的显示
速度上,后者明显加快。这时,【功能实现窗体】中的控件已变成一个象征性的图
标,对它的操作,可在控制图标的对应位置上设置一个Image 类型的图象框,通过
对图象框的操作,来代替原先对控制对象的操作。
采用这种方法,使窗体界面设计的灵活性大大增加,可以任意发挥,而不用担
心控件、图片太多,影响窗体的显示速度。但采用这种方法,将不可避免地增加应
用程序本身所占的存储容量,这是以容量换取速度必须付出的代价。
二、 动态功能提示信息的实现
在现代软件设计中,多数功能图标、按钮都在界面上直接确定其对应的名称,
同时也提供了动态提示的功能,即当鼠标移至某一控件时,或使鼠标的形状用一具
有象征意义的图标代替,或自动出现一条文字提示,下面介绍一下如何实现这种先
进的提示模式。
动态改变鼠标的图形形状,是通过控件的MousePointer属性设置为13(自定义)
,然后在MouseIeon属性中选取一ICO图标文件来完成的;动态文字提示功能是利用
控件的MouseMove事件来实现的:将功能提示处理程序设计在对应的MouseMove事件
过程中,当鼠标移动到该控件范围区域时,即可触发程序执行,完成动态功能提示;
为了防止处理程序反复触发,必须设置一控制开关,使处理程序只在鼠标第一次触
发该控件区域时被执行;取消功能提示的处理程序设计在窗体的MouseMove事件中,
说明程序如下:
Dim FirstTouch As Boolean '防止反复触发处理程序的控制变量
Private Sub ControlObject- MouseMove ()
If FirstTouch Then
FirstTouch =False '显示功能提示字符
End Sub
 
Private Sub Form- MouseMove ()
FirstTouch =True '取消功能提示字符
End Sub



</PRE>

页: 1 2 3 [4] 5 6

Powered by Discuz! Archiver 7.2  © 2001-2009 Comsenz Inc.