【你共享我给分】版内活动：挖掘VB潜能，征集变态应用
挖掘VB潜能，请把你认为经典的、变态的代码贴上来。
让大家共同研究、共同进步，也让更多的人看看VB的厉害。
严重注意：仅限VB源码，可内嵌机器码。
本帖300分只给大家公认的最杰出的两个人，分配比例待定。
其他经典代码可获得100-1000不等的可用分。
贴代码请注明版权或来源，谢谢。
[解决办法]
哇哈哈!!!我来占沙发~~~
发一个简易ListView类,希望可以代替那一堆OCX!
目前功能比较单一,我会慢慢完善它的.
链接:(10-14楼)
http://topic.csdn.net/u/20080529/00/3a4031d5-6d1b-4d31-bb3f-30a7c4473dd8.html
不敢说原创,因为这些都是MSDN或网上资料里能查到的,我只是将其组合一下,纯体力活.....
[解决办法]
占个狙击位......
[解决办法]
唉
当了好多年工人
都是东拼西凑的
没原创过
[解决办法]
先頂起,再學習
[解决办法]
贴个上次C代码的提权函数，这次改成VB的了比较爽一个API
Option Explicit
'提权相关常数
Public Const SE_MIN_WELL_KNOWN_PRIVILEGE = 2
Public Const SE_CREATE_TOKEN_PRIVILEGE = 2
Public Const SE_ASSIGNPRIMARYTOKEN_PRIVILEGE = 3
Public Const SE_LOCK_MEMORY_PRIVILEGE = 4
Public Const SE_INCREASE_QUOTA_PRIVILEGE = 5
' end_wdm
'
' Unsolicited Input is obsolete and unused.
'
Public Const SE_UNSOLICITED_INPUT_PRIVILEGE = 6
' begin_wdm
Public Const SE_MACHINE_ACCOUNT_PRIVILEGE = 6
Public Const SE_TCB_PRIVILEGE = 7
Public Const SE_SECURITY_PRIVILEGE = 8
Public Const SE_TAKE_OWNERSHIP_PRIVILEGE = 9
Public Const SE_LOAD_DRIVER_PRIVILEGE = 10
Public Const SE_SYSTEM_PROFILE_PRIVILEGE = 11
Public Const SE_SYSTEMTIME_PRIVILEGE = 12
Public Const SE_PROF_SINGLE_PROCESS_PRIVILEGE = 13
Public Const SE_INC_BASE_PRIORITY_PRIVILEGE = 14
Public Const SE_CREATE_PAGEFILE_PRIVILEGE = 15
Public Const SE_CREATE_PERMANENT_PRIVILEGE = 16
Public Const SE_BACKUP_PRIVILEGE = 17
Public Const SE_RESTORE_PRIVILEGE = 18
Public Const SE_SHUTDOWN_PRIVILEGE = 19
Public Const SE_DEBUG_PRIVILEGE = 20
Public Const SE_AUDIT_PRIVILEGE = 21
Public Const SE_SYSTEM_ENVIRONMENT_PRIVILEGE = 22
Public Const SE_CHANGE_NOTIFY_PRIVILEGE = 23
Public Const SE_REMOTE_SHUTDOWN_PRIVILEGE = 24
Public Const SE_UNDOCK_PRIVILEGE = 25
Public Const SE_SYNC_AGENT_PRIVILEGE = 26
Public Const SE_ENABLE_DELEGATION_PRIVILEGE = 27
Public Const SE_MANAGE_VOLUME_PRIVILEGE = 28
Public Const SE_IMPERSONATE_PRIVILEGE = 29
Public Const SE_CREATE_GLOBAL_PRIVILEGE = 30
Public Const SE_MAX_WELL_KNOWN_PRIVILEGE = SE_CREATE_GLOBAL_PRIVILEGE
Public Const STATUS_NO_TOKEN = &HC000007C
Private Declare Function RtlAdjustPrivilege Lib "ntdll.dll" (ByVal Privilege As Long, ByVal Enable As Boolean, ByVal Client As Boolean, WasEnabled As Long) As Long
Public Function EnablePrivilege(ByVal Privilege As Long, Enable As Boolean) As Boolean
Dim ntStatus As Long
Dim WasEnabled As Long
ntStatus = RtlAdjustPrivilege(Privilege, Enable, True, WasEnabled)
If ntStatus = STATUS_NO_TOKEN Then
ntStatus = RtlAdjustPrivilege(Privilege, Enable, False, WasEnabled)
End If
If ntStatus = 0 Then
EnablePrivilege = True
Else
EnablePrivilege = False
End If
End Function
[解决办法]
强贴留名~
[解决办法]
那我发个管道重定向的代码，上次花200分买来的哈哈。
管道重定向将stdin/stdout重定向到程序定义的输入输出流中，这样就可以截获多数控制台应用程序的输出，也可以向其输入内容。
- VB code
'新建工程,添加两个文本框txtMessage与txtCommand.'前者的MultLine=True,用于显示命令行程序的回显;'后者用于输入命令.Option ExplicitPrivate Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal lpApplicationName As String, ByVal lpCommandLine As String, lpProcessAttributes As Any, lpThreadAttributes As Any, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, lpEnvironment As Any, ByVal lpCurrentDriectory As String, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As LongPrivate Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As LongPrivate Declare Function CreatePipe Lib "kernel32" (phReadPipe As Long, phWritePipe As Long, lpPipeAttributes As Any, ByVal nSize As Long) As LongPrivate Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Any) As LongPrivate Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Any) As LongPrivate Declare Function SetHandleInformation Lib "kernel32" (ByVal hObject As Long, ByVal dwMask As Long, ByVal dwFlags As Long) As LongPrivate Declare Function SetNamedPipeHandleState Lib "kernel32" (ByVal hNamedPipe As Long, lpMode As Long, lpMaxCollectionCount As Long, lpCollectDataTimeout As Long) As LongPrivate Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)Private Type STARTUPINFO cb As Long lpReserved As String lpDesktop As String lpTitle As String 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 LongEnd TypePrivate Type PROCESS_INFORMATION hProcess As Long hThread As Long dwProcessId As Long dwThreadId As LongEnd TypePrivate Const STARTF_USESTDHANDLES = &H100Private Const HANDLE_FLAG_INHERIT = 1Private Const DETACHED_PROCESS = &H8Private Const PIPE_NOWAIT = &H1Dim hReadPipe As LongDim hWritePipe As LongDim hChildReadPipe As LongDim hChildWritePipe As Long'上面是公共部分.Private Sub Form_Load() txtCommand.Text = "" txtMessage.Text = "" txtMessage.Locked = True ' 创建管道 CreatePipe hReadPipe, hWritePipe, ByVal 0, ByVal 0 CreatePipe hChildReadPipe, hChildWritePipe, ByVal 0, ByVal 0 SetHandleInformation hWritePipe, HANDLE_FLAG_INHERIT, HANDLE_FLAG_INHERIT SetHandleInformation hChildReadPipe, HANDLE_FLAG_INHERIT, HANDLE_FLAG_INHERIT Dim dwMode As Long dwMode = PIPE_NOWAIT SetNamedPipeHandleState hReadPipe, dwMode, ByVal 0, ByVal 0 ' 创建CMD进程 Dim stProcessInfo As PROCESS_INFORMATION Dim stStartInfo As STARTUPINFO stStartInfo.cb = LenB(stStartInfo) stStartInfo.dwFlags = STARTF_USESTDHANDLES stStartInfo.hStdError = hWritePipe stStartInfo.hStdOutput = hWritePipe stStartInfo.hStdInput = hChildReadPipe Dim strExe As String strExe = "cmd" If False = CreateProcess(ByVal vbNullString, ByVal strExe, ByVal 0, ByVal 0, ByVal True, ByVal DETACHED_PROCESS, ByVal 0, ByVal vbNullString, stStartInfo, stProcessInfo) Then MsgBox "启动进程失败!" Exit Sub Else CloseHandle stProcessInfo.hThread CloseHandle stProcessInfo.hProcess End If ReadFromChildPipeEnd SubPrivate Sub Form_Unload(Cancel As Integer) CloseHandle hReadPipe CloseHandle hWritePipe CloseHandle hChildReadPipe CloseHandle hChildWritePipeEnd SubPrivate Sub txtCommand_KeyPress(KeyAscii As Integer) If KeyAscii = vbKeyReturn Then Dim nWrite As Long Dim strBuffer As String strBuffer = txtCommand.Text & vbCrLf Dim bResult As Boolean bResult = WriteFile(ByVal hChildWritePipe, ByVal strBuffer, ByVal Len(strBuffer), nWrite, ByVal 0) If bResult = True Then ReadFromChildPipe Else MsgBox "写入失败." End If txtCommand.Text = "" End IfEnd SubPrivate Sub ReadFromChildPipe() Dim nRead As Long Dim strBuffer As String Dim nBufferLen As Long nRead = -1 Do While nRead <> 0 nBufferLen = 65536 strBuffer = String(nBufferLen, Chr(0)) Sleep 10 ReadFile hReadPipe, ByVal strBuffer, ByVal nBufferLen, nRead, ByVal 0 Sleep 10 If nRead <> 0 Then strBuffer = Left(strBuffer, nRead) txtMessage.Text = txtMessage.Text & strBuffer txtMessage.SelStart = Len(txtMessage.Text) End If LoopEnd Sub
[解决办法]
转一个VB结合汇编提高VB效率的：比 SuperCopyMemory 还快的 IcyCopyMemory!
- VB code
' IcyCopyMemory [code by iceboy] - 40% faster than RtlMoveMemory' Tested on WinXP SP3 / E2160 oc 3Ghz / DDR2 800 - 2.79GB/s' MSN: icediy#non-spam#hotmail#dot#com / QQ: 41785691' API DeclarationPrivate Declare Function CallWindowProcW Lib "user32" (ByRef lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As LongPrivate Declare Function VirtualProtect Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flNewProtect As Long, ByRef lpflOldProtect As Long) As LongPrivate Declare Sub RtlMoveMemory Lib "ntdll" (ByVal pDst As Long, ByVal pSrc As Long, ByVal dwLength As Long)Dim Asm(37) As Long, AsmStub(1) As Long, AsmPtr As Long, IDEMode As LongPrivate Const PAGE_EXECUTE_READWRITE As Long = &H40Private Function RetLng(ByVal dwAny As Long) As Long RetLng = dwAnyEnd FunctionPrivate Sub InitAsm() Dim FuncAddr As Long, OldProtect As Long Asm(0) = &H8B575651: Asm(1) = &H8B10247C: Asm(2) = &H8B142474: Asm(3) = &H5118244C Asm(4) = &HF33FE183: Asm(5) = &HE18359A4: Asm(6) = &H6850FC0: Asm(7) = &H5F000000 Asm(8) = &HCC2595E: Asm(9) = &H3E9C100: Asm(10) = &H8DCE348D: Asm(11) = &HD9F7CF3C Asm(12) = &HCE84180F: Asm(13) = &H200&: Asm(14) = &HCE046F0F: Asm(15) = &HCE4C6F0F Asm(16) = &H4E70F08: Asm(17) = &H4CE70FCF: Asm(18) = &H6F0F08CF: Asm(19) = &HF10CE44 Asm(20) = &H18CE4C6F: Asm(21) = &HCF44E70F: Asm(22) = &H4CE70F10: Asm(23) = &H6F0F18CF Asm(24) = &HF20CE44: Asm(25) = &H28CE4C6F: Asm(26) = &HCF44E70F: Asm(27) = &H4CE70F20 Asm(28) = &H6F0F28CF: Asm(29) = &HF30CE44: Asm(30) = &H38CE4C6F: Asm(31) = &HCF44E70F Asm(32) = &H4CE70F30: Asm(33) = &HC18338CF: Asm(34) = &HFA57508: Asm(35) = &H770FF8AE Asm(36) = &HC2595E5F: Asm(37) = &HC& AsmStub(0) = &HFF505A58: AsmStub(1) = &HE2& AsmPtr = VarPtr(Asm(0)) FuncAddr = RetLng(AddressOf IcyCopyMemory) VirtualProtect FuncAddr, 5, PAGE_EXECUTE_READWRITE, OldProtect RtlMoveMemory FuncAddr, VarPtr(&HE9), 1 RtlMoveMemory FuncAddr + 1, VarPtr(AsmPtr - (FuncAddr + 5)), 4 VirtualProtect FuncAddr, 5, OldProtect, OldProtectEnd SubPrivate Function SetIDE() As Boolean IDEMode = -1 SetIDE = TrueEnd FunctionPublic Sub IcyCopyMemory(ByVal pDst As Long, ByVal pSrc As Long, ByVal dwLength As Long) If AsmPtr = 0 Then InitAsm Debug.Assert SetIDE If IDEMode = 0 Then IcyCopyMemory pDst, pSrc, dwLength Else CallWindowProcW AsmStub(0), AsmPtr, pDst, pSrc, dwLength End IfEnd Sub
[解决办法]
看大家发的代码都是API方面的应用,我就不发哪方面的了
我发一个超简单的VB小代码吧！
long to byte
- VB code
Option ExplicitPrivate Type byt b1 As Byte b2 As Byte b3 As Byte b4 As ByteEnd TypePrivate Type itg l As LongEnd TypePrivate Sub Form_Load()Dim bb As bytDim i As itgi.l = 2345LSet bb = iDebug.Print bb.b1, bb.b2, bb.b3, bb.b4End Sub
[解决办法]
进来学习
[解决办法]
收藏 ，都是vb强人
[解决办法]
从二进制中加载图片!
- VB code
Public Function LoadFile(ByVal FileName As String) As Byte() Dim FileNo As Integer, b() As Byte On Error GoTo Err_Init If Dir(FileName, vbNormal Or vbArchive) = "" Then Exit Function End If FileNo = FreeFile Open FileName For Binary Access Read As #FileNo ReDim b(0 To LOF(FileNo) - 1) Get #FileNo, , b Close #FileNo LoadFile = b Exit FunctionErr_Init: MsgBox Err.Number & " - " & Err.DescriptionEnd FunctionPublic Function PictureFromByteStream(b() As Byte) As IPicture Dim LowerBound As Long Dim ByteCount As Long Dim hMem As Long Dim lpMem As Long Dim IID_IPicture(15) Dim istm As stdole.IUnknown On Error GoTo Err_Init If UBound(b, 1) < 0 Then Exit Function End If LowerBound = LBound(b) ByteCount = (UBound(b) - LowerBound) + 1 hMem = GlobalAlloc(&H2, ByteCount) If hMem <> 0 Then lpMem = GlobalLock(hMem) If lpMem <> 0 Then MoveMemory ByVal lpMem, b(LowerBound), ByteCount Call GlobalUnlock(hMem) If CreateStreamOnHGlobal(hMem, 1, istm) = 0 Then If CLSIDFromString(StrPtr("{7BF80980-BF32-101A-8BBB-00AA00300CAB}"), IID_IPicture(0)) = 0 Then Call OleLoadPicture(ByVal ObjPtr(istm), ByteCount, 0, IID_IPicture(0), PictureFromByteStream) End If End If End If End If Exit Function Err_Init: If Err.Number = 9 Then 'Uninitialized array MsgBox "You must pass a non-empty byte array to this function!" Else MsgBox Err.Number & " - " & Err.Description End IfEnd Function
[解决办法]
超强，好深奥哦，佩服一下
[解决办法]
up !
[解决办法]
你们都发API的，我发一个简单的，也是自己的：
前段时间有人说PictureBox控件不能显示GIF动画，主要是动画不能动。我说，可以动！
PictureBox控件显示GIF动画
- VB code
'在PictureBox控件中显示GIF动画（图片）,凡有句柄hwnd的窗体控件均可以'在窗体Form1上添加2个命令按钮Command1,Command2和1个图片框控件Picture1Option Explicit'调用运动图像类型库Quartz.dll,在c:\windows\system32目录下Private pMC As FilgraphManager '定义pMC为FilgraphManager对象Private pVW As IVideoWindow '定义pVW为IVideoWindow对象Private Sub Command1_Click() On Error Resume Next Set pMC = New FilgraphManager pMC.Stop pMC.RenderFile "" '加载GIF文件 On Error GoTo Lhandle pMC.RenderFile "E:\offline.gif" '加载GIF动画（图片） On Error Resume Next Set pVW = pMC pVW.WindowStyle = CLng(&H6000000) '限定动画在Picture1的大小中 pVW.Left = 0: pVW.Top = 0 pVW.Width = Picture1.ScaleWidth pVW.Height = Picture1.ScaleHeight pVW.Owner = Picture1.hWnd '在Picture1中显示 pVW.MessageDrain = Picture1.hWnd '此行非常重要，用来定义动画的右键菜单所必须 pMC.Run Exit SubLhandle: MsgBox ("加载文件错误！")End SubPrivate Sub Command2_Click() pMC.Stop Set pVW = Nothing Set pMC = NothingEnd SubPrivate Sub Form_Load() Me.ScaleMode = 3 Picture1.ScaleMode = 3End Sub
[解决办法]
抗议！
上面的代码都是正常得不能再正常的应用，没有一个[b]变态[/b]的！
应改加一个规矩：贴正常代码的要受罚！
[解决办法]
写菜单类时用到的例程，用各种风格画边框和填充，拿来干别的也很通用。尤其是支持非矩形渐变色 Alpha 填充，可以实现很漂亮的效果。
- VB code
'[作者 Soyokaze]Private Enum BorderStyle '边框风格 BS_NONE = 0 BS_RAISED = BDR_RAISEDINNER BS_SUNKEN = BDR_SUNKENINNER BS_ETCHED = EDGE_ETCHED BS_BUMP = EDGE_BUMP BS_SOLID = &H11 BS_DASH = &H12 BS_DOT = &H13 BS_ROUNDRECT = &H20End EnumPrivate Enum FillStyle '背景填充风格 FS_NONE = 0 FS_SOLIDCOLOR = &H1 FS_GRADIENT_H = &H2 FS_GRADIENT_V = &H4 FS_MIRROREFFECT = &H20End Enum'绘制边框与填充Private Function StyleDrawFill(ByVal hDCDst As Long, _ tRectDst As RECT, _ ByVal eBorder As BorderStyle, _ ByVal eFill As FillStyle, _ ByVal crBorder As Long, _ ByVal crFill1 As Long, _ Optional ByVal crFill2 As Long, _ Optional ByVal byFillAlpha As Byte = 255) As Boolean Dim hDCSrc As Long, hDCMask As Long Dim hBmpSrc As Long, hBmpOld1 As Long Dim hBmpMask As Long, hBmpOld2 As Long Dim hPen As Long, hPenOld As Long Dim hBrush As Long, hBrushOld As Long Dim tRect As RECT Dim tPoint(2) As POINTAPI Dim tBlend As BLENDFUNCTION Dim lpBlend As Long Dim tVertex(3) As TRIVERTEX Dim tGRect(1) As GRADIENT_RECT Dim nBorderWidth As Long '边框 Select Case eBorder Case BS_NONE Case BS_RAISED, BS_SUNKEN Call DrawEdge(hDCDst, tRectDst, eBorder, BF_RECT) Case BS_ETCHED, BS_BUMP Call DrawEdge(hDCDst, tRectDst, eBorder, BF_RECT) nBorderWidth = nBorderWidth + 1 Case Else hPen = CreatePen(Choose(eBorder And &HF, PS_SOLID, PS_DASH, PS_DOT), 1, crBorder) hBrush = GetStockObject(NULL_BRUSH) hPenOld = SelectObject(hDCDst, hPen) hBrushOld = SelectObject(hDCDst, hBrush) If CBool(eBorder And BS_ROUNDRECT) Then Call RoundRect(hDCDst, tRectDst.Left, tRectDst.Top, tRectDst.Right, tRectDst.Bottom, 6, 6) Else Call Rectangle(hDCDst, tRectDst.Left, tRectDst.Top, tRectDst.Right, tRectDst.Bottom) End If Call DeleteObject(SelectObject(hDCDst, hPenOld)) Call SelectObject(hDCDst, hBrushOld) End Select nBorderWidth = nBorderWidth + 1
[解决办法]
不管怎样，偶先收藏再说……………………
[解决办法]
用MSXML2.FreeThreadDomDocument 的 OnReadyStateChange 事件来做多线程算不算变态？
代码找不到了……
[解决办法]
好贴，记录下！
[解决办法]
[Quote=引用:]
好贴，记录下！
[/Quote]
现在这年头，有Vb.net了，咋还要用VB呢》
[解决办法]
俺贴点逻辑方面的
VB中解决两个大数相与(and)
- VB code
Option ExplicitPrivate Sub Command1_Click() Debug.Print dec2hex("12379814471884843981") Debug.Print hex2dec("ABCDEFABCDEFABCD") Debug.Print hex2dec(myand(dec2hex("429496729742949672974294967297"), dec2hex("429442949672974294967297967296")))End SubPrivate Function myand(ByVal hexa As String, ByVal hexb As String) As String Dim m As Long Dim n As Long Dim a As Byte Dim b As Byte Dim c As Byte Dim r As String m = Len(hexa) n = Len(hexb) If m < n Then hexa = String(n - m, "0") & hexa m = n End If If n < m Then hexb = String(m - n, "0") & hexb n = m End If Dim l As Long l = Len(hexa) Dim i As Long For i = 1 To l a = Val("&h" & Mid(hexa, i, 1)) b = Val("&h" & Mid(hexb, i, 1)) c = a And b r = r & Trim(Hex$(c)) Next i myand = r End FunctionPrivate Function dec2hex(ByVal dec As String) As String Dim n(1 To 100) As Byte Dim c As Byte Dim l As Long Dim i As Long Dim j As Long l = Len(dec) For i = 1 To l c = Val(Mid(dec, i, 1)) For j = 100 To 2 Step -1 n(j) = n(j) * 10 Next j n(100) = n(100) + c For j = 100 To 2 Step -1 If n(j) > 15 Then n(j - 1) = n(j - 1) + n(j) \ 16 n(j) = n(j) Mod 16 End If Next j Next i Dim s As String For i = 1 To 100 If n(i) > 0 Then For j = i To 100 s = s & Trim(Hex$(n(j))) Next j dec2hex = s Exit Function End If Next iEnd FunctionPrivate Function hex2dec(ByVal hexx As String) As String Dim n(1 To 100) As Byte Dim c As Byte Dim l As Long Dim i As Long Dim j As Long l = Len(hexx) For i = 1 To l c = Val("&h" & Mid(hexx, i, 1)) For j = 100 To 2 Step -1 n(j) = n(j) * 16 Next j n(100) = n(100) + c For j = 100 To 2 Step -1 If n(j) > 9 Then n(j - 1) = n(j - 1) + n(j) \ 10 n(j) = n(j) Mod 10 End If Next j Next i Dim s As String For i = 1 To 100 If n(i) > 0 Then For j = i To 100 s = s & Trim(CStr(n(j))) Next j hex2dec = s Exit Function End If Next iEnd Function
[解决办法]
强VB高人....
....
[解决办法]
- VB code
MessageBox "Hello World!"
[解决办法]
赞，赞 赞！！！
[解决办法]
看看我写的
用ActiveReport1.1解决2000，XP下无法使用自定义纸张的程序
ActiveReport数据源设置和自定义纸张程序，放置在打印按钮的程序中：
Set rs3=New Recordset
rs3.CursorLocation=adUseClient
rs3.Open "select * from back_produce where 单据编号="&Val(Text1),conn, adOpenKeyset,adLockPessimistic
If rs3.RecordCount=0 Then
Me.MousePointer=0
Exit Sub
End If
With ActiveReport4
Set .DataControl1.Recordset=rs3
.Printer.DeviceName=""'清空打印设置
.Printer.PaperSize=256'设置纸张为自定义
.Printer.PaperHeight=14*567'设置纸张高度
.Printer.PaperWidth=24.1*567'设置纸张宽度
.Printer.Orientation=ddOPortrait'设置纸张走向[现在的设置是横向]
.Show 1'设置显示方式，置顶
End With
在Private Sub ActiveReport_DataInitialize()中添加的程序
On Error Resume Next'设置错误陷阱
If ActiveReport4.DataControl1.Recordset.EOF Then Exit Sub
With ActiveReport4
.Field2.DataSource="DataControl1"'设置控件的数据源
.Field2.DataField="商品编号"'设置控件的数据字段
.Field3.DataSource="DataControl1"
.Field3.DataField="商品全名"
.Field4.DataSource="DataControl1"
.Field4.DataField="单位"
.Field5.DataSource="DataControl1"
.Field5.DataField="数量"
.Field6.DataSource="DataControl1"
.Field6.DataField="单价"
.Field7.DataSource="DataControl1"
.Field7.DataField="金额"
End With
Err.Clear'清除错误
Printer.DeviceName ="Canon BJC-265SP"'设置打印机默认项为不存在的打印类型
注：在Private Sub ActiveReport_DataInitialize()中添加的程序是在报表控件中选择的，在选项中有此一项。
[解决办法]
好贴。
[解决办法]
LZ这个提意真是好，把大家的积极性都调出来了，，多搞点这种贴子。
大家顶住贴，过二天我贴个纯VB KILL Rising2008的代码出来。
昨晚已经在Win 2000 Server测试通过，今天回去在WIN XP上测试一下
然后整理一下代码贴出来
虽然没有过主动防御，但既使被它抓住了，一样让瑞星崩掉，而且没有任何
系统提示的错误信息，只是在用户下次使用瑞星时，瑞星将只能调用出个CMD
然后就退出，至于里面瑞星写了什么我也不知道。
[解决办法]
[解决办法]
好贴！
林子大了，总有个别S鸟，不要因他们影响心情啊。
[解决办法]
不错，支持！
[解决办法]
赫赫，现在没见到入法眼的，阿弥陀法
[解决办法]
好地方，关注，学习。
[解决办法]
这个帖子强！！！我进来学习下！！！！
[解决办法]
@@
[解决办法]
vb程序镶入汇编语言实现一些vb不太好实现的功能是不是可以的分？
[解决办法]
这样算不算BT呢
- VB code
Dim 十六进制字符集() As StringDim 八进制字符集() As StringDim 二进制字符集() As StringFunction N进制to十进制(n进制字符 As String, 字符集() As String, Optional 区分大小写 As Boolean = False) As Variant Dim 进制数 As Long Dim X As Long Dim TempStr As String Dim ReturnLong As Long Dim NowData As Long Dim RetDate As Long 进制数 = UBound(字符集) - LBound(字符集) + 1 If 区分大小写 = False Then '如果不区分大小写就统一字符 n进制字符 = UCase(n进制字符) End If For X = 1 To Len(n进制字符) TempStr = Mid(n进制字符, X, 1) NowData = -1 RetDate = -1 For Y = LBound(字符集) To UBound(字符集) NowData = NowData + 1 If TempStr = 字符集(Y) Then RetDate = NowData Exit For End If Next Y If RetDate <> -1 Then ReturnLong = ReturnLong + 进制数 ^ (Len(n进制字符) - X) * RetDate Else '非法的进制符号 N进制to十进制 = Null Exit Function End If Next X N进制to十进制 = ReturnLongEnd FunctionPrivate Sub Form_Load() ReDim 十六进制字符集(0 To 15) ReDim 八进制字符集(0 To 7) ReDim 二进制字符集(0 To 1) Dim X As Long '初始化二进制字符集 For X = 0 To 1 二进制字符集(X) = CStr(X) Next X '初始化八进制字符集 For X = 0 To 7 八进制字符集(X) = CStr(X) Next X '初始化十六进制字符集 For X = 0 To 9 十六进制字符集(X) = CStr(X) Next X For X = 10 To 15 十六进制字符集(X) = Chr(65 + (X - 10)) Next X '函数使用范例 Msgbox N进制to十进制("FFFF", 十六进制字符集) Msgbox N进制to十进制("7777", 八进制字符集) Msgbox N进制to十进制("110011", 二进制字符集)End Sub
[解决办法]
为什么论坛帖子没分页啊。看的辛苦死了