大家都把自己收藏的好东东拿出共享吧

3）Creating a 'Floating' Window
==================================================================
'BAS
Option Explicit
Public Const GWL_HWNDPARENT = (-8)
Public Declare Function SetWindowLong Lib "user32" _
    Alias "SetWindowLongA"_
   (ByVal hwnd As Long, ByVal nIndex As Long, _
    ByVal wNewLong As Long) As Long
'--------------------------------------------------------
'Form
Option ExplicitPrivate OriginalParenthWnd As Long
Private Sub Form_Load()   OriginalParenthWnd = SetWindowLong(Me.hwnd, _
                                      GWL_HWNDPARENT, _
                                      parent.hwnd)End Sub
Private Sub Form_Unload()  'Restore the original parent before unloading
   Call SetWindowLong(Me.hwnd, GWL_HWNDPARENT, OriginalParenthWnd)End Sub
Private Sub Command1_Click()  'force the Unload sub to execute to end,
  'preventing a crash
   Unload Me  'In addition, make sure that the parent form
  'implicitly unloads the floating form before it
  'unloads itself.End Sub

这是什么？
PhotoShop风格的进度条？！

我那个程序（经典代码：自定义系统的打开对话框。http://www.csdn.net/expert/topic/560/560709.xml?temp=2.434939E-02）
不是收藏的！
是我自己写的！
因为网上没有VB的自定义打开对话框的例子，我是参照一个VC例子写的。

'以下是我收藏的旋转位图的一段原码
'请保存为Rotate.frm
Type=Exe
Form=Rotate.frm
Object={F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.1#0; COMDLG32.OCX
Object={BDC217C8-ED16-11CD-956C-0000C04E4C0A}#1.1#0; TABCTL32.OCX
Object={3B7C8863-D78F-101B-B9B5-04021C009402}#1.1#0; RICHTX32.OCX
Object={6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.1#0; COMCTL32.OCX
Object={FAEEE763-117E-101B-8933-08002B2F4F5A}#1.1#0; DBLIST32.OCX
Object={00028C01-0000-0000-0000-000000000046}#1.0#0; DBGRID32.OCX
Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#..\..\SYSTEM\StdOle2.tlb#Standard OLE Types
Reference=*\G{00025E01-0000-0000-C000-000000000046}#4.0#0#..\..\..\PROGRAM FILES\COMMON FILES\ MICROSOFT SHARED\C:\PROGRAM FIL#Microsoft DAO 3.0 Object Library
IconForm="Form1"
Startup="Form1"
Command32=""
Name="Project1"
HelpContextID="0"
CompatibleMode="0"
MajorVer=1
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
VersionCompanyName="Custom Electronics"
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
ThreadPerObject=0
MaxNumberOfThreads=1

'请存为Rotate.frm
VERSION 5.00
Begin VB.Form Form1
   Caption         =   "Rotate Bitmap"
   ClientHeight    =   4140
   ClientLeft      =   1575
   ClientTop       =   1530
   ClientWidth     =   6690
   LinkTopic       =   "Form1"
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   276
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   446
   Begin VB.TextBox Text1
      Height          =   285
      Left            =   480
      TabIndex        =   5
      Top             =   2760
      Width           =   1455
   End
   Begin VB.PictureBox Rot
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      BackColor       =   &H00000000&
      BorderStyle     =   0  'None
      ForeColor       =   &H0000FF00&
      Height          =   735
      Left            =   0
      ScaleHeight     =   49
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   65
      TabIndex        =   1
      Top             =   0
      Width           =   975
      Begin VB.CommandButton Ren
         Caption         =   "Ren"
         Height          =   255
         Left            =   240
         TabIndex        =   4
         Top             =   0
         Visible         =   0   'False
         Width           =   495
      End
      Begin VB.CommandButton Rl
         Caption         =   "L"
         Height          =   255
         Left            =   0
         TabIndex        =   3
         Top             =   0
         Width           =   255
      End
      Begin VB.CommandButton Rr
         Caption         =   "R"
         Height          =   255
         Left            =   720
         TabIndex        =   2
         Top             =   0
         Width           =   255
      End
   End
   Begin VB.PictureBox Store
      AutoRedraw      =   -1  'True
      Height          =   1575
      Left            =   4320
      Picture         =   "Rotate.frx":0000
      ScaleHeight     =   101
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   133
      TabIndex        =   0
      Top             =   240
      Width           =   2055
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nwidth As Long, ByVal nheight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function PatBlt Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal nwidth As Long, ByVal nheight As Long, ByVal dwRop As Long) As Long
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nwidth As Long, ByVal nheight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) 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 CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function FloodFill Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Const SRCCOPY = &HCC0020
Const BLACKNESS = &H42&
Const SrcPaint = &HEE0086
Const SRCAND = &H8800C6
Const SRCINVERT = &H660046
Dim a, b, c, d, e, f, g, r, pi, zz, cx, cy, bx, by, zr, sc, drawcolor, Sscr&, stool, ww, tool, gbs, x1, y1, sx, sy, deg, ims, ti, Sh, Sw, scv, Picwidth, Picheight, Bm&, tp&, tmp&
Dim Px, Py, S, Ital, Wt, Ht, Thick, Esc, Ul, Fontuse, Fbc, Dm, Filcolor
'还没完。

'接上一段
Sub Rotate()
Rot.ScaleMode = 3
Rem this routine draws the square one side at a time
Rem by = center Y of bitmap and  bx = center X of the bitmap
Rem e = Work Box center X and f = Work Box center Y
Rem a holds the Degrees and b = right side c = Bottom d = left side
Rem zx and zy are just temparary variables
pi = 4 * Atn(1): pi = (pi / 180): a = deg: b = (deg + 90): c = (deg + 180): d = (deg + 270)
e = (Form1.Rot.ScaleWidth / 2) - 2: f = (Form1.Rot.ScaleHeight / 2) - 2: Form1.Rot.DrawWidth = 1
zx = (by * Sin(a * pi) + e): zy = (by * Cos(a * pi) + f)
Form1.Rot.Line (-bx * Sin((a + 90) * pi) + zx, -bx * Cos((a + 90) * pi) + zy)-(bx * Sin((a + 90) * pi) + zx, bx * Cos((a + 90) * pi) + zy), QBColor(10)
zx = (bx * Sin(b * pi) + e): zy = (bx * Cos(b * pi) + f):
Form1.Rot.Line (-by * Sin((b + 90) * pi) + zx, -by * Cos((b + 90) * pi) + zy)-(by * Sin((b + 90) * pi) + zx, by * Cos((b + 90) * pi) + zy), QBColor(10)
zx = (by * Sin(c * pi) + e): zy = (by * Cos(c * pi) + f)
Form1.Rot.Line (-bx * Sin((c + 90) * pi) + zx, -bx * Cos((c + 90) * pi) + zy)-(bx * Sin((c + 90) * pi) + zx, bx * Cos((c + 90) * pi) + zy), QBColor(10)
zx = (bx * Sin(d * pi) + e): zy = (bx * Cos(d * pi) + f)
Form1.Rot.Line (-by * Sin((d + 90) * pi) + zx, -by * Cos((d + 90) * pi) + zy)-(by * Sin((d + 90) * pi) + zx, by * Cos((d + 90) * pi) + zy), QBColor(10)
Text1.Text = "  " + Str$(deg) + " Degrees"
End Sub
Private Sub Form_Load()
Rem set the Rot.PictureBox to an area big enough to hold the Bitmap on a 45 degree angle
Rem now copy the bitmap into it to start rotations
Rem and Position the buttons
Rr.Left = Rot.Width - Rr.Width: deg = 0
bx = (Store.ScaleWidth / 2): by = (Store.ScaleHeight / 2)
a = (Form1.Store.Width * Form1.Store.Width) + (Form1.Store.Height * Form1.Store.Height): b = Sqr(a)
Form1.Rot.Top = 0: Form1.Rot.Left = 0:
Form1.Rot.Width = b: Form1.Rot.Height = b: Form1.Rot.Visible = True: Form1.Ren.Visible = True
a = (b / 2) - 1: tmp = BitBlt(Form1.Rot.hdc, (a - bx), (a - by), Form1.Store.Width, Form1.Store.Height - 6, Form1.Store.hdc, 0, 0, SRCCOPY)
Form1.Ren.Left = (Rot.Width / 2) - (Form1.Ren.Width / 2) + 4: Form1.Ren.Top = 6
Rr.Left = Rot.ScaleWidth - Rr.Width: Ren.Left = (Rot.ScaleWidth / 2 - Ren.Width / 2): Ren.Top = 0
Text1.Text = "  " + Str$(deg) + "   Degrees"
End Sub
Private Sub Ren_Click()
r = 0: Ren.Visible = False: Rr.Visible = False: Rl.Visible = False
Rot.AutoRedraw = False
Rem setup the draw in degrees function
pi = 4 * Atn(1): pi = (pi / 180): a = deg: b = (deg + 90): c = (deg + 180): d = (deg + 270)
e = (Rot.ScaleWidth / 2) - 2: f = (Rot.ScaleHeight / 2) - 2: Form1.Rot.DrawWidth = 1
Rem Do a palette copy so the colors will come out right in 256 colors
Clipboard.Clear: Clipboard.SetData Form1.Picture, 9
Form1.Rot.Picture = Clipboard.GetData(9)
Rem setup the variables
Dim cc As Long
Form1.Rot.DrawMode = 13
tby = (by - 2): lft = 0: rt = 0: Form1.Rot.Cls
Rem loop through the bitmap getting one pixel color at a time
Rem and paste them down on the new position on the rot.PictureBox
Rem the for next loop does one scan line at a time
Rem the loop counts down then vertical scan lines to the bottom on the bitmap
Rem useing tby as a checkpoint
Rem Note that everything is calculated from the center
lpf:
For stx = (bx - 2) To (-bx + 2) Step -1
cc = Form1.Store.Point(lft, rt): lft = lft + 1
zx = (tby * Sin(c * pi) + e): zy = (tby * Cos(c * pi) + f)
tmp = SetPixel(Form1.Rot.hdc, (stx * Sin((c + 90) * pi) + zx), (stx * Cos((c + 90) * pi) + zy), cc)
tmp = SetPixel(Form1.Rot.hdc, (stx * Sin((c + 90) * pi) + zx), (stx * Cos((c + 90) * pi) + zy + 1), cc)
Next: lft = 0: rt = rt + 1
tby = tby - 1: If tby > (-by + 2) Then GoTo lpf
Rem replace the buttons for another rotation
Ren.Visible = True
Rl.Visible = True: Rr.Visible = True
End Sub
Private Sub Rl_Click()
Rem draw the square
Form1.Rot.DrawMode = 6
If r = 1 Then Rotate: r = 0
If deg < 360 Then deg = deg + 2: Rotate: r = 1
End Sub
Private Sub Rr_Click()
Rem draw the square
Form1.Rot.DrawMode = 6
If r = 1 Then Rotate: r = 0
deg = deg - 2: Rotate: r = 1
End Sub

'上面的已发完，
'我试试这个行不行
'rotate.frx是资源文件：）如不行的话，运行程序后在PICTUREBOX中再放入一个位图就可以了

sorry第一个是Rotate.vbp谢谢zyl910(910：分儿，我来了！) 的提醒：）
这个是我在一个网站上看到的：）

创建 GUID
==============================================================
Private Declare Function CoCreateGuid Lib "OLE32.DLL" _
    (pGUID As GUID) As LongPrivate Declare Function StringFromGUID2 Lib "OLE32.DLL" _
    (pGUID As GUID, _
     ByVal PointerToString As Long, _
     ByVal MaxLength As Long) As LongPrivate Type GUID
    Guid1 As Long
    Guid2 As Long
    Guid3 As Long
    Guid4(0 To 7) As Byte
End TypePublic Function CreateGUID() As String    Dim udtGUID As GUID
    Dim sGUID As String
    Dim lResult As Long    lResult = CoCreateGuid(udtGUID)    If lResult Then
        sGUID = ""
    Else
        sGUID = String$(38, 0)
        StringFromGUID2 udtGUID, StrPtr(sGUID), 39
    End If    CreateGUID = sGUIDEnd Function
==============================================================

我豁出去了！
写“大字”的程序：http://go6.163.com/910grtd/vb/wdzp/BigText.htm（请用IE下载）

哇。以后每次上CSDN都可以看见NNNNNNNNNN多的大字
CSDN将“永无宁日”（开个玩笑）

捕获 DOS 输出程序（请帮忙 up）
===================================================================
VERSION 5.00
Begin VB.Form frmDOSOutput
   Caption         =   "DOS Outputs"
   ClientHeight    =   4590
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   7395
   LinkTopic       =   "Form1"
   ScaleHeight     =   4590
   ScaleWidth      =   7395
   StartUpPosition =   3  'Windows Default
   Begin VB.TextBox txtCommand
      Height          =   285
      Left            =   120
      TabIndex        =   4
      Top             =   360
      Width           =   7095
   End
   Begin VB.CommandButton cmdExit
      Caption         =   "Exit"
      Height          =   375
      Left            =   5280
      TabIndex        =   2
      Top             =   4080
      Width           =   1875
   End
   Begin VB.TextBox txtOutputs
      BeginProperty Font
         Name            =   "Courier New"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00000000&
      Height          =   3135
      Left            =   120
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   1
      Top             =   720
      Width           =   7155
   End
   Begin VB.CommandButton cmdExecute
      Caption         =   "Execute"
      Default         =   -1  'True
      Height          =   375
      Left            =   3240
      TabIndex        =   0
      Top             =   4080
      Width           =   1875
   End
   Begin VB.Label Label1
      AutoSize        =   -1  'True
      Caption         =   "Command:"
      Height          =   195
      Left            =   120
      TabIndex        =   3
      Top             =   120
      Width           =   750
   End
End
Attribute VB_Name = "frmDOSOutput"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'DOSOutpus
'Capture the outputs of a DOS command
'Author: Marco Pipino
'[email protected]
'28/02/2002
Option ExplicitPrivate WithEvents objDOS As DOSOutputs
Attribute objDOS.VB_VarHelpID = -1Private Sub cmdExecute_Click()
    On Error GoTo errore
    objDOS.CommandLine = txtCommand.Text
    objDOS.ExecuteCommand
    Exit Sub
errore:
    MsgBox (Err.Description & " - " & Err.Source & " - " & CStr(Err.Number))
End SubPrivate Sub cmdExit_Click()
    Set objDOS = Nothing
    End
End SubPrivate Sub Form_Load()
    Set objDOS = New DOSOutputs
End SubPrivate Sub objDOS_ReceiveOutputs(CommandOutputs As String)
    txtOutputs.Text = txtOutputs.Text & CommandOutputs
End SubPrivate Sub txtOutputs_Change()
    txtOutputs.SelStart = Len(txtOutputs.Text)
End Sub

’------------------------------------------------------------
’.CLS
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "DOSOutputs"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit'The CreatePipe function creates an anonymous pipe,
'and returns handles to the read and write ends of the pipe.
Private Declare Function CreatePipe Lib "kernel32" ( _
    phReadPipe As Long, _
    phWritePipe As Long, _
    lpPipeAttributes As Any, _
    ByVal nSize As Long) As Long'Used to read the the pipe filled by the process create
'with the CretaProcessA function
Private Declare Function ReadFile Lib "kernel32" ( _
    ByVal hFile As Long, _
    ByVal lpBuffer As String, _
    ByVal nNumberOfBytesToRead As Long, _
    lpNumberOfBytesRead As Long, _
    ByVal lpOverlapped As Any) As Long'Structure used by the CreateProcessA function
Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Long
End Type'Structure used by the CreateProcessA function
Private Type STARTUPINFO
    cb As Long
    lpReserved As Long
    lpDesktop As Long
    lpTitle As Long
    dwX As Long
    dwY As Long
    dwXSize As Long
    dwYSize As Long
    dwXCountChars As Long
    dwYCountChars As Long
    dwFillAttribute As Long
    dwFlags As Long
    wShowWindow As Integer
    cbReserved2 As Integer
    lpReserved2 As Long
    hStdInput As Long
    hStdOutput As Long
    hStdError As Long
End Type'Structure used by the CreateProcessA function
Private Type PROCESS_INFORMATION
    hProcess As Long
    hThread As Long
    dwProcessID As Long
    dwThreadID As Long
End Type'This function launch the the commend and return the relative process
'into the PRECESS_INFORMATION structure
Private Declare Function CreateProcessA Lib "kernel32" ( _
    ByVal lpApplicationName As Long, _
    ByVal lpCommandLine As String, _
    lpProcessAttributes As SECURITY_ATTRIBUTES, _
    lpThreadAttributes As SECURITY_ATTRIBUTES, _
    ByVal bInheritHandles As Long, _
    ByVal dwCreationFlags As Long, _
    ByVal lpEnvironment As Long, _
    ByVal lpCurrentDirectory As Long, _
    lpStartupInfo As STARTUPINFO, _
    lpProcessInformation As PROCESS_INFORMATION) As Long'Close opened handle
Private Declare Function CloseHandle Lib "kernel32" ( _
    ByVal hHandle As Long) As Long'Consts for the above functions
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const STARTF_USESTDHANDLES = &H100&
Private Const STARTF_USESHOWWINDOW = &H1
Private mCommand As String          'Private variable for the CommandLine property
Private mOutputs As String          'Private variable for the ReadOnly Outputs property'Event that notify the temporary buffer to the object
Public Event ReceiveOutputs(CommandOutputs As String)'This property set and get the DOS command line
'It's possible to set this property directly from the
'parameter of the ExecuteCommand method
Public Property Let CommandLine(DOSCommand As String)
    mCommand = DOSCommand
End PropertyPublic Property Get CommandLine() As String
    CommandLine = mCommand
End Property'This property ReadOnly get the complete output after
'a command execution
Public Property Get Outputs()
    Outputs = mOutputs
End PropertyPublic Function ExecuteCommand(Optional CommandLine As String) As String
    Dim proc As PROCESS_INFORMATION     'Process info filled by CreateProcessA
    Dim ret As Long                     'long variable for get the return value of the
                                        'API functions
    Dim start As STARTUPINFO            'StartUp Info passed to the CreateProceeeA
                                        'function
    Dim sa As SECURITY_ATTRIBUTES       'Security Attributes passeed to the
                                        'CreateProcessA function
    Dim hReadPipe As Long               'Read Pipe handle created by CreatePipe
    Dim hWritePipe As Long              'Write Pite handle created by CreatePipe
    Dim lngBytesread As Long            'Amount of byte read from the Read Pipe handle
    Dim strBuff As String * 256         'String buffer reading the Pipe    'if the parameter is not empty update the CommandLine property
    If Len(CommandLine) > 0 Then
        mCommand = CommandLine
    End If

    'if the command line is empty then exit whit a error message
    If Len(mCommand) = 0 Then
        MsgBox "Command Line empty", vbCritical
        Exit Function
    End If

    'Create the Pipe
    sa.nLength = Len(sa)
    sa.bInheritHandle = 1&
    sa.lpSecurityDescriptor = 0&
    ret = CreatePipe(hReadPipe, hWritePipe, sa, 0)

    If ret = 0 Then
        'If an error occur during the Pipe creation exit
        MsgBox "CreatePipe failed. Error: " & Err.LastDllError, vbCritical
        Exit Function
    End If

    'Launch the command line application
    start.cb = Len(start)
    start.dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW
    'set the StdOutput and the StdError output to the same Write Pipe handle
    start.hStdOutput = hWritePipe
    start.hStdError = hWritePipe
    'Execute the command
    ret& = CreateProcessA(0&, mCommand, sa, sa, 1&, _
        NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc)

    If ret <> 1 Then
        'if the command is not found ....
        MsgBox "File or command not found", vbCritical
        Exit Function
    End If

    'Now We can ... must close the hWritePipe
    ret = CloseHandle(hWritePipe)
    mOutputs = ""

    'Read the ReadPipe handle
    Do
        ret = ReadFile(hReadPipe, strBuff, 256, lngBytesread, 0&)
        mOutputs = mOutputs & Left(strBuff, lngBytesread)
        'Send data to the object via ReceiveOutputs event
        RaiseEvent ReceiveOutputs(Left(strBuff, lngBytesread))
    Loop While ret <> 0

    'Close the opened handles
    ret = CloseHandle(proc.hProcess)
    ret = CloseHandle(proc.hThread)
    ret = CloseHandle(hReadPipe)

    'Return the Outputs property with the entire DOS output
    ExecuteCommand = mOutputs
End Function

  Private  Declare  Function  EnumDisplaySettings  Lib  "user32"  Alias  "EnumDisplaySettingsA"  (ByVal  lpszDeviceName  As  Long,  ByVal  iModeNum  As  Long,  lpDevMode  As  Any)  As  Boolean
  Private  Declare  Function  ChangeDisplaySettings  Lib  "user32"  Alias  "ChangeDisplaySettingsA"  (lpDevMode  As  Any,  ByVal  dwFlags  As  Long)  As  Long
  Private  Declare  Function  ExitWindowsEx  Lib  "user32"  (ByVal  uFlags  As  Long,  ByVal  dwReserved  As  Long)  As  Long
  Private  Const  EWX_LOGOFF  =  0
  Private  Const  EWX_SHUTDOWN  =  1
  Private  Const  EWX_REBOOT  =  2
  Private  Const  EWX_FORCE  =  4
  Private  Const  CCDEVICENAME  =  32
  Private  Const  CCFORMNAME  =  32
  Private  Const  DM_BITSPERPEL  =  &  H40000
  Private  Const  DM_PELSWIDTH  =  &  H80000
  Private  Const  DM_PELSHEIGHT  =  &  H100000
  Private  Const  CDS_UPDATEREGISTRY  =  &  H1
  Private  Const  CDS_TEST  =  &  H4
  Private  Const  DISP_CHANGE_SUCCESSFUL  =  0
  Private  Const  DISP_CHANGE_RESTART  =  1
  Private  Type  DEVMODE
          dmDeviceName  As  String  *  CCDEVICENAME
          dmSpecVersion  As  Integer
          dmDriverVersion  As  Integer
          dmSize  As  Integer
          dmDriverExtra  As  Integer
          dmFields  As  Long
          dmOrientation  As  Integer
          dmPaperSize  As  Integer
          dmPaperLength  As  Integer
          dmPaperWidth  As  Integer
          dmScale  As  Integer
          dmCopies  As  Integer
          dmDefaultSource  As  Integer
          dmPrintQuality  As  Integer
          dmColor  As  Integer
          dmDuplex  As  Integer
          dmYResolution  As  Integer
          dmTTOption  As  Integer
          dmCollate  As  Integer
          dmFormName  As  String  *  CCFORMNAME
          dmUnusedPadding  As  Integer
          dmBitsPerPel  As  Integer
          dmPelsWidth  As  Long
          dmPelsHeight  As  Long
          dmDisplayFlags  As  Long
          dmDisplayFrequency  As  Long
  End  Type
  'Example

  Private  Sub  Form_Load()

  'Changes  the  resolution  to  640x480  with  the  current  colordepth.

  Dim  DevM  As  DEVMODE  '注释：Get  the  info  into
  DevMerg&    =  EnumDisplaySettings(0&  ,  0&  ,  DevM)  '注释：We  don't  change  the  colordepth,  because  a  reboot  will  be  necessary
  DevM.dmFields  =  DM_PELSWIDTH  Or  DM_PELSHEIGHT  Or  DM_BITSPERPEL
  DevM.dmPelsWidth  =  640  'ScreenWidth
  DevM.dmPelsHeight  =  480  'ScreenHeight
  DevM.dmBitsPerPel  =  8  '(could  be  8,  16,  32  or  even  4)
  'Now  change  the  display  and  check  if  possible
  erg&    =  ChangeDisplaySettings(DevM,  CDS_TEST)
  'Check  if  succesfull
  Select  Case  erg&
  Case  DISP_CHANGE_RESTART
          an  =  MsgBox("You：ve  to  reboot",  vbYesNo  +  vbSystemModal,  "Info")
          If  an  =  vbYes  Then
                  erg&    =  ExitWindowsEx(EWX_REBOOT,  0&  )
          End  If
  Case  DISP_CHANGE_SUCCESSFUL
          erg&    =  ChangeDisplaySettings(DevM,  CDS_UPDATEREGISTRY)
          MsgBox  "Everythings  ok",  vbOKOnly  +  vbSystemModal,  "It  worked!"
  Case  Else
          MsgBox  "Mode  not  supported",  vbOKOnly  +  vbSystemModal,  "Error"
  End  Select
  End  Sub



在form的resize事件里编写代码，让窗口自适应分辨率的改变。
  下面是具体的一个例子
  Private  Sub  Form_Resize()
  On  Error  GoTo  errHandle
  With  fraAccept
  .Left  =  100
  .Top  =  100
  .Width  =  Me.Width  -  picEdit.Width  -  400
  End  With

  With  dtgAccept
  .Top  =  200
  .Left  =  100
  .Width  =  fraAccept.Width  -  220
  .Height  =  fraAccept.Height  -  290
  End  With

  With  picEdit
  .Left  =  fraAccept.Width  +  200
  .Top  =  190
  End  With

  With  picControl
  .Top  =  200  +  fraAccept.Height
  .Width  =  Me.Width  -  300
  .Left  =  100
  End  With

  With  fraRepair
  .Top  =  fraAccept.Height  +  picControl.Height  +  300
  .Width  =  picControl.Width
  .Height  =  Me.Height  -  (fraAccept.Height  +  picControl.Height  +  800)
  End  With

  With  dtgRepair
  .Top  =  530
  .Left  =  100
  .Width  =  fraRepair.Width  -  220
  .Height  =  fraRepair.Height  -  600
  End  With

  errHandle:
  End  Sub

/*随机函数*/
/*功能:产生一个完全随机数"arandom()"*/
/*_arandom.h*/
#include<stdlib.h>
#include<time.h>
arandom(){
time_t startf,timer;
time_t time(time_t *timer);
int random;
startf=time(&timer);
srand(startf);
random=rand();
return(random);
}/*使用方法：*/
#include "_arandom.h
/*.............*/srand(arandom())/*这样一来随机数种子就被改变了每次运行会产生不同的随机数这是rand()做不到的*/

我想我们当中应有即懂VB又懂C　的才发了上面的那个：）

别忘了将_arandom.h拷到include目录下

Get Modem Port
===============================================================
Option ExplicitPrivate Sub Form_Load()
  Dim s As String
  Dim iPort As Integer
  Dim n As Single
  Dim bModem As Boolean

  For iPort = 1 To 4
    With MSComm1
      .CommPort = iPort
      .Settings = "9600,N,8,1"
      .InputLen = 0
      On Error Resume Next
      .PortOpen = True
      If Err = 0 Then
        .Output = "ATV1Q0" & Chr$(13)
        n = Timer
        While Timer - n < 1
          DoEvents
        Wend
        s = s & .Input
        .PortOpen = False
        If InStr(s, "OK" & vbCrLf) <> 0 Then
          MsgBox "Modem detected on COM" & iPort
          bModem = True
          Exit For
        End If
      End If
    End With
  Next
  If Not bModem Then MsgBox "No modem detected"
  End
End Sub

http://www27.brinkster.com/vcshcn/soft.asp
可不可以帮一下呀:
http://www.csdn.net/expert/topic/556/556391.xml

异步通知可以实现现两个EXE进行通信
共实现方式决不是一种，以下是利用内存共享来实现的代码例子：'\\ Global memory management functions
private Declare Function GlobalLock Lib "kernel32" (byval hMem as Long) as Longprivate Declare Function GlobalSize Lib "kernel32" (byval hMem as Long) as Longprivate Declare Function GlobalUnlock Lib "kernel32" (byval hMem as Long) as Longprivate Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest as Any, lpvSource as Any, byval cbCopy as Long)private Declare Function GlobalAlloc Lib "kernel32" (byval wFlags as Long, byval dwBytes as Long) as Longprivate Declare Function GlobalFree Lib "kernel32" (byval hMem as Long) as Long
private mMyData() as Byte
private mMyDataSize as Long
private mHmem as Long
public Enum enGlobalmemoryAllocationConstants
GMEM_FIXED = &H0
GMEM_DISCARDABLE = &H100
GMEM_MOVEABLE = &H2
GMEM_NOCOMPACT = &H10
GMEM_NODISCARD = &H20
GMEM_ZEROINIT = &H40
End Enum
'**************************************
' Name: Global memory
' Description:Allows you to read and wri
' te global memory blocks, which in turn a
' llows you to pass big chunks of data bet
' ween applications easily.
' By: Duncan Jones
'
'
' Inputs:None
'
'\\ --[CopyFromHandle]---------------------------
'\\ Copies the data from a global memory handle
'\\ to a private byte array copy
'\\ ---------------------------------------------public Sub CopyFromHandle(byval hMemHandle as Long)
Dim lRet as Long
Dim lPtr as Long
lRet = GlobalSize(hMemHandle)
If lRet > 0 then
mMyDataSize = lRet
lPtr = GlobalLock(hMemHandle)
If lPtr > 0 then
ReDim mMyData(0 to mMyDataSize - 1) as Byte
CopyMemory mMyData(0), byval lPtr, mMyDataSize
Call GlobalUnlock(hMemHandle)
End If
End If
End Sub
'\\ --[CopyToHandle]-----------------------------
'\\ Copies the private data to a memory handle
'\\ passed in
'\\ ---------------------------------------------public Sub CopyToHandle(byval hMemHandle as Long)
Dim lSize as Long
Dim lPtr as Long
'\\ Don't copy if its empty
If Not (mMyDataSize = 0) then
lSize = GlobalSize(hMemHandle)
'\\ Don't attempt to copy if zero size..If lSize > 0 then
lPtr = GlobalLock(hMemHandle)
If lPtr > 0 then
CopyMemory byval lPtr, mMyData(0), lSize
Call GlobalUnlock(hMemHandle)
End If
End If
End If
End Sub

谢谢 Bardo 参与！
下面是个 VBS 文件，大师的作品：
==================================================================
'  Registering/Unregsitering TLB Files.
'  Created by Jason Bock, 05/04/1999
'  Original Idea Conceived by Bruce McKinney
'
'  This script file will register or unregister a given type library.
'
'  To use this file, type:
'
'       wscript "scriptfilelocation\tlbregister.vbs" "typelibraryfilelocation" -r/u
'
'  where
'
'       wscript:  Name of the scripting engine EXE.
'       "scriptfilelocation\tlbregister.vbs":  The location of this script file.
'       "typelibraryfilelocation":  The location of the TLB file.
'       -r/u:  If -r, the TLB file will be registered.
'              If -u, the TLB file will be unregistered.
'
'  If you want to debug the script file, uncomment the next line.
'StopOn Error Resume NextDim lngC
Dim objTLB
Dim objArgs
Dim strTLBFile
Dim strTLBRegisterSwitchSet objArgs = WScript.ArgumentsIf Not objArgs Is Nothing Then
    Err.Clear
    Set objTLB = WScript.CreateObject("TLI.TLIApplication")
    If Not objTLB Is Nothing Then
        strTLBFile = Trim(objArgs.Item(0))
        strTLBRegisterSwitch = Trim(UCase(objArgs.Item(1)))
        If strTLBRegisterSwitch = "-R" Then
            Err.Clear
            objTLB.TypeLibInfoFromFile(strTLBFile).Register
            If Err.Number = -2147467259 Or Err.Number = 0 Then
                WScript.Echo "Registration successful."
            Else
                WScript.Echo "Registration error:  " & Err.Number & " - " & Err.Description
            End If
        ElseIf strTLBRegisterSwitch = "-U" Then
            Err.Clear
            objTLB.TypeLibInfoFromFile(strTLBFile).UnRegister
            If Err.Number = -2147467259 Or Err.Number = 0 Then
                WScript.Echo "Unregistration successful."
            Else
                WScript.Echo "Unregistration error:  " & Err.Number & " - " & Err.Description
            End If
        Else
            WScript.Echo "Unidentified type library registration switch."
        End If
        Set objTLB = Nothing
    Else
        WScript.Echo "TLI.TLIApplication Object Creation Error."
    End If
    Set objArgs = Nothing
End If

UDT聊天：
Option Explicit
Private IgnoreText As BooleanPrivate Sub cmdClear_Click()
Text1 = ""
With Text2
   'Clear the text window and
   .Text = ""
   'return the focus
   .SetFocus
End With
End SubPrivate Sub cmdConnect_Click()
On Error GoTo ErrHandlerWith Winsock1
   'Set the remotehost property
   .RemoteHost = Trim(txtRemoteIP)
   'Set the remoteport property.
   'This should be equal to the
   'localhost property of the
   'remote machine.
   .RemotePort = Trim(txtRemotePort)
   'The localport property cannot be
   'changed,so check if it has already
   'been set.
   If .LocalPort = Empty Then
      .LocalPort = Trim(txtLocalPort)
      Frame2.Caption = .LocalIP
      .Bind .LocalPort
   End If
End With'Make sure that the user can't change
'the local port
txtLocalPort.Locked = True
'Show the current status of the connection in
'the status bar
StatusBar1.Panels(1).Text = "连接到" & Winsock1.RemoteHost & ""Frame1.Enabled = True
Frame2.Enabled = True
Label4.Visible = TrueText2.SetFocus
Exit SubErrHandler:
MsgBox "Winsock无法正确连接。", vbCritical
End SubPrivate Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyF1 Then
ChDir App.Path
Shell "notepad.exe readme.txt", vbNormalFocus
End IfEnd SubPrivate Sub Form_Load()
Show
txtRemoteIP = Winsock1.LocalIP
End SubPrivate Sub Text2_KeyPress(KeyAscii As Integer)'The position of the last linefeed within the text
Static Last_Line_Feed As Long'The new line of text
Dim New_Line As String
'Reset the position of the last line feed if the
'user has clear the chat window
If Trim(Text2) = vbNullString Then Last_Line_Feed = 0
'If the user pressed Enter...
If KeyAscii = 13 Then
   'Get the new line of text
   New_Line = Mid(Text2, Last_Line_Feed + 1)
   'Save the position of the current linefeed
   Last_Line_Feed = Text2.SelStart
   'Send the new text across the socket
   Winsock1.SendData New_Line
   StatusBar1.Panels(2).Text = "传输速度为" & (LenB(New_Line) / 2) & "bytes"
End IfEnd SubPrivate Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
'New_Text is the text that has just arrived
'from across the socket
Dim New_Text As String
'Get the new text
Winsock1.GetData New_Text
'Show the new text
Text1.SelText = New_Text
Frame1.Caption = Winsock1.RemoteHostIP
'Show the byte size of this transmission in the statusbar
StatusBar1.Panels(2).Text = "接收速度为" & bytesTotal & "bytes"
End Sub

http://listenshaw.myetang.comhttp://listenshaw.myetang.com/sourcedb/data/index.htm

http://listenshaw.myetang.comhttp://listenshaw.myetang.com/sourcedb/data/index.htm我收藏的一些源代码！

最近想出来的几个算法：
http://www.csdn.net/expert/topic/486/486765.xml 16位色下抖动算法
http://www.csdn.net/expert/topic/559/559353.xml 256色下抖动算法

对不起，刚才网络出问题了，发了这么多。
我编的一些游戏源码，请指教：
http://thirdapple.home.chinaren.com/Tankwar.htm
http://thirdapple.home.chinaren.com/Smario.htm
http://thirdapple.home.chinaren.com/VBFight.htm

大家不觉得这么发帖子会浪费资源么？浪费资源是不对的（怎么来了个唐僧？？？）大家把源码压缩了放到网上，大家去下载不好么？我的一个程序3000多行代码，才是一个开头，现在还没写完呢。要是贴上去，CSDN还不把我的ID给删了。

是啊！比如我那个自画菜单的程序（http://go6.163.com/910grtd/vb/wdzp/CoolGUI.htm），压缩后都有160K。

Amoon(阿木) ：久仰前辈大名。
我听 sonicdater（发呆呆）说起过你老人家。
敬佩！！！

调试易

大家都把自己收藏的好东东拿出共享吧

解决方案 »