cbm666
cbm666
关注数: 28
粉丝数: 1,517
发帖数: 26,280
关注贴吧数: 4
【CBM666 资源文件的释放】 源代码下载: http://tieba.baidu.com/mo/q/checkurl?url=http%3A%2F%2Fcbm666.cn%2Fsoftware%2F&urlrefer=d867951978d0aba47627fc429fa2102b资源文件释放(变色龙).rar
【CBM666 十进制二进制转换】 【工控】两个字简单的来说不外乎就是接点 0/1开关状态检测 ,接收仪表设备数据, 定时或定量检测当前数据是否超标, 适时的响应设备开关或暂停或转向的动作. 本帖所探讨的就是接点检测 一般的I/O板卡, 返回方式基本上大半都是以十进制数值返回, 因此在学习VB6的过程中,我们就必须了解二进制与十进制之间的转换关系, 例如下图: 8个接点 每个接点都标识着数字,代表8位的01顺序数值, 1 以红色球表示 0 以绿色球表示, 以本例来说 1 2 3 5 8 有5个接点是导通运行中 加总个别数值 1+2+4+16+128 = 151 所以当我们接收到151数值后,经过拆解便可知道那个接点是导通或断开。'这个代码用在工控I/O接点检测 判定某个接点为 0(关闭状态) 或 1(打开状态) '十进制与二进制的转换 '添加 Text1 Command1 Command2 Command3 Label1 Shape1(0) '128,64,32,16,8,4,2,1 (从右边往左算是1-128 连乘2 合计 255) '可以理解为2的7次方 7次方 6次方 5次方。。。。。0次方 Option Explicit Private WithEvents Timer1 As Timer Dim i&, j&, aa$ '变量定义与型态声明 Private Sub Form_Load() Command1.Caption = "10转2" Command2.Caption = "2转10" Command3.Caption = "随机灯号" Command1.Enabled = True Command2.Enabled = False Text1.Text = "151" '比方说I/O板卡返回 151 转为二进制得到 10010111 '****************************** For i = 1 To 7 '循环线上添加 7个 Shape数组 形状控件 与原先的1个 共有8个 Load Shape1(i) '装载控件 索引编号为i Shape1(i).Visible = True '线上添加的控件默认为不可见 我们得将它设为 可见 Shape1(i).Left = Shape1(i - 1).Left + Shape1(0).Width + 70 '定位新添加的控件,在前一个控件的位置加上宽度再加上间距70 Next i '******************************* Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2 '窗体定位于屏幕中心 Command1_Click '自动点击按钮1 将十进制的151转为二进制 Set Timer1 = Controls.Add("vb.Timer", "Timer1") '线上添加 Timer1 定时器控件 Timer1.Interval = 3000: Timer1.Enabled = False '定时器Timer1的激发间隔设为3000毫秒 暂时禁用 Me.Caption = "工控第一课 研华PCI-1761 I/O 板卡" Label1.Caption = "151" End Sub Private Sub Command1_Click() '十进制转二进制 If Command3.Caption = "停止演示" Then Command3_Click '如果随机演示正在进行中 我们先自动点击按钮3 让它停止演示 'Text1.Text是文字形态 我们必须先使用Val函数将它转为数值 '调用 Ten2Two 副程序将Text1.Text转换过的数值 转换为文字型态的二进制 再赋值给 Text1.Text Text1.Text = Format(Ten2Two(Val(Text1.Text)), "00000000") For i = 1 To Len(Text1.Text) '从1开始循环到Text1长度 '如果Shape1数组i-1的值为0 Shape1的颜色显示绿色 否则显示红色 Shape1(i - 1).FillColor = IIf(Mid(Text1.Text, i, 1) = 0, QBColor(10), QBColor(12)) Next i Command1.Enabled = Not Command1.Enabled 'Not的使用技术原理是反向 假变成真 真变成假 Command2.Enabled = Not Command2.Enabled '让两个按钮反向为 可用或不可用 End Sub Private Sub Command2_Click() '二进制转十进制 If Command3.Caption = "停止演示" Then Command3_Click '如果随机演示正在进行中 我们先自动点击按钮3 让它停止演示 '调用副程序Two2Ten 将Text1文本框内的二进制内容转换返回数值 '再使用 Cstr函数将此数值转换为文字型态 再用 Trim函数将此文字型内容左右两边可能的空白字符去掉 Text1.Text = Trim(CStr(Two2Ten(Text1.Text))) Command1.Enabled = Not Command1.Enabled '让两个按钮反向为 可用或不可用 Command2.Enabled = Not Command2.Enabled End Sub Private Sub Command3_Click() '随机演示数值转换并显示相应的灯号 Command3.Caption = IIf(Command3.Caption = "随机灯号", "停止演示", "随机灯号") Timer1.Enabled = Not Timer1.Enabled '定时器反向 开始或停止演示 End Sub Function Ten2Two(ByVal Tvalue As Long) As String '十进制转二进制 If Tvalue = 0 Then Ten2Two = "00000000": Exit Function aa = "" Do Until Tvalue < 1 '循环直到变量Tvalue的值小于 1 才结束循环 aa = CStr(Tvalue And 1) & aa '变量aa 逐一累加 Tvalue = Tvalue \ 2 '将变量Tvalue除以2 将此数值去除小数 整数化 Loop Ten2Two = aa '将文字变量aa返回 End Function Function Two2Ten(ByVal Tstr As String) As Long '二进制转十进制 Dim TmpVal& '定义数值型变量 TmpVal j = Len(Trim(Tstr)) '将参数Tstr去除空白后计算它的长度(几个字符) 赋值给 j For i = 1 To j '从第一个字符开始循环到j个字符 '变量开始逐一累加i的?次方 TmpVal = IIf(Val(Mid(Tstr, j - (i - 1), 1)) > 0, TmpVal + 2 ^ (i - 1), TmpVal) Next i Two2Ten = TmpVal '将数值变量TmpVal返回 End Function Private Sub Timer1_Timer() '定时器的事件 Dim RndVal& '变量定义 Timer1.Enabled = False '换算过程前暂时先让定时器停止运行 Randomize '随机数种子初始化 RndVal = Int(Rnd * 256) '0-255共256个数 随机取值 '将取到的随机数调用副程序Ten2Two 将十进制接收值转换为0与1的二进制后 赋值给文字型变量aa aa = Format(Trim(CStr(Ten2Two(RndVal))), "00000000") Label1.Caption = CStr(RndVal) '让标签显示接收到(随机数)的十进制值 Text1.Text = aa '文本框Text1显示变量aa的内容 For i = 1 To Len(aa) '从第一个字符开始循环到变量aa包含几个字符 '如果Shape1数组i-1的值为0 Shape1的颜色显示绿色 否则显示红色 Shape1(i - 1).FillColor = IIf(Mid(aa, i, 1) = "0", QBColor(10), QBColor(12)) Next i Timer1.Enabled = True '换算完成后再让定时器继续运行 End Sub
【CBM666 十六进制数值的转换】 我们知道16进制的元素是0123456789ABCDEF 总共16个元素的集合,我们经常需要将16进制换算为10进制或2进制,尤其是串口或网口通讯, VB6提供了Hex函数 能将10进制数值转换为16进制, 但是VB6却没有提供如何将16进制转换为10进制数值的函数, 如何计算这个数值, 下面列出计算式便可明白了 例如: 16进制 【1234ABCD】 换算为10进制数值的计算式: 0123456789当大于9时 就转为ABCDEF来替代 A=10 B=11 C=12 D=13 E=14 F=15 Tval = 1 * 16 ^ 7 + 2 * 16 ^ 6 + 3 * 16 ^ 5 + 4 * 16 ^ 4 + 10 * 16 ^ 3 + 11 * 16 ^ 2 + 12 * 16 ^ 1 + 13 * 16 ^ 0 MsgBox Tval 将返回 305441741 Tval 就是1234ABCD的10进制数值 再将10进制数值还原回来就很简单了, 只要使用VB6自带的函数Hex即可 MsgBox Hex(Tval) 将返回 305441741 再举一个例 FFFFFFFF F 的10进制值 = 15 例如: 16进制 【FFFFFFFF】 换算为10进制数值的计算式: Tval = 15 * 16 ^ 7 + 15 * 16 ^ 6 + 15 * 16 ^ 5 + 15 * 16 ^ 4 + 15 * 16 ^ 3 + 15 * 16 ^ 2 + 15 * 16 ^ 1 + 15* 16 ^ 0 MsgBox Tval 将返回 4294967295 MsgBox Hex(Tval) 将返回 FFFFFFFF
【CBM666 远程监控摄像头的概念】 远程监控摄像头 当今物流产业盛行的年代 到处可见得天眼, 估计大家都知道 都见过, 但是要用VB6或APP安卓手机编程或任何其它语言,想入门都不容易, 其实没你们想象的那么难, 今天给大家一个概念, 无论任何厂牌的摄像头都是一个共通的思路,每个网络摄像头出厂时都会给一个不重复的 唯一的设备序列号, 透过厂家给的SDK 获取厂家的公网IP 端口号 加上自己的设备序列号与密码,指定连接厂家的服务器, 你便可以在全世界有wifi的地方用电脑 用平板 用手机 随时都可以看得到远在千里外的摄像头画面. 有兴趣的人可以看看下面代码 不懂得的地方可以问我Private Sub Form_Load() Dim VER_AX_LOCALE As String Dim szDevIP As String Dim nPort As Long Dim szAuthAcc, szAuthPwd As String Dim nImgW, nImgH As Integer Dim szDecName As String Dim nDevType As Long Dim bInLan As Long Dim preActTime As Data Dim bNeedStop As Boolean VER_AX_LOCALE = "11.21.35.174" szDevIP = "VSTC761754JXXXX" 'IP Camera 买硬件时 每个硬件都会有唯一的序列号 nPort = 81 'IP Camera port szAuthAcc = "cbm666" 'IP Camera account szAuthPwd = "88XXX8" szDevName = "镜头通道1" 'IPCam Caption nDevType = 922 'nDevType的值用IP访问时改为926,用UID访问的时候改为922 bInLan = 0 '1:局域网 0:广域网 Remote.StopRec Remote.ConnMode = 0 Remote.ShowTitle = 0 Remote.Selected = 1 Remote.Lan = "cn" 'Language Remote.ShowOSDName = 0 Remote.CanPopupMenu = True Remote.Proxy = "server.ipcam.so" Remote.SwitchLayout ("1 x 1") Remote.ShowToolBar = 0 Remote.Listen = -1 nImgW = Remote.Width 'IPCam resolution nImgH = Remote.Height Remote.AddDev4 nDevType, bInLan, szDevIP, nPort, szDevName, szAuthAcc, szAuthPwd, 1 Remote.TurnImg = 0 Remote.TCPMode = 2 Remote.VideoRate = 20 Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height - GetTaskbarHeight * 15) \ 2 '窗体居中 End Sub Private Sub Form_Activate() Remote.ConnectAll Remote.Start preActime = 0 bNeedStop = False End Sub Private Sub Form_Unload(Cancel As Integer) Remote.DisConnectAll Set MainForm = Nothing End End Sub Public Sub setAction(action As Long, time As Long) Remote.PTZ 1, 1, action, time, 0, 0 bNeedStop = action <> -1 preActTime = now_time End Sub Public Sub StopAction() Remote.PTZ 1, 1, -1, 0, 0, 0 bNeedStop = False End Sub Private Sub Focus1_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) Call setAction(4, 31) End Sub Private Sub Focus1_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) Call setAction(-1, 0) End Sub Private Sub Focus2_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) Call setAction(5, 31) End Sub Private Sub Focus2_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) Call setAction(-1, 0) End Sub Private Sub Timer1_Timer() 'Call StopAction End Sub Private Sub Zoom1_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) Call setAction(6, 31) End Sub Private Sub Zoom1_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) Call setAction(-1, 0) End Sub Private Sub Zoom2_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) Call setAction(7, 31) End Sub Private Sub Zoom2_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) Call setAction(-1, 0) End Sub Private Sub Command1_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) Select Case Index Case 0 '朝左 Call setAction(1, 31) Case 1 '朝右 Call setAction(2, 31) Case 2 '朝上 Call setAction(0, 31) Case 3 '朝下 Call setAction(3, 31) Case 4 '云台开始旋转 If Command1(4).Caption = "开始扫描" Then Remote.PTZ 1, 1, 8, 20, 0, 0 Command1(4).Caption = "停止扫描" Else 'Remote.PTZ 1, 1, -1, 1, 0, 0 Call setAction(-1, 0) Command1(4).Caption = "开始扫描" End If End Select End Sub Private Sub Command1_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) Select Case Index Case 0 '朝左 Call setAction(-1, 0) Case 1 '朝右 Call setAction(-1, 0) Case 2 '朝上 Call setAction(-1, 0) Case 3 '朝下 Call setAction(-1, 0) Case 4 '云台开始旋转 'Call setAction(-1, 0) End Select End Sub
【CBM666 VB6 VS 安卓手机】 VB6操作远程服务器 Mysql Mssql 你想在【全界各地】都能拿着手机就能操作 以VB6当后台处理的数据库吗? VB6与现场的PLC或单片机连线作业, 你想在【全界各地】都能拿着手机改变流程改变配方或浏览传感器数据吗? VB6当后台总管 遥控手机拨打电话或发短信给 VB6操作指定的人吗? VB6当后台总管 遥控手机控制你家里的所有空调 窗帘 电灯 洗衣机 电饭煲家用电气设备吗? 不管是VB6直接操作 或手机独立操作都能完成你的需求 未来趋势------- 智能化工业农业商业家居物联网 VB6 还是能扮演着【总司令】的角色, 别再小看VB6啦 想学这些技术 将你的VB6发挥极致 可以加我的群学习 请先明白一点 如果你的 Basic 或 VBA 或 VB6的功力能编出小小的小程序, 你就有能力学会 安卓手机编程
【CBM666 工作上的难题欢迎进入】 工作不易,碰上难题在所难免, 往往猛钻死胡同, 当局者迷, 浪费大把时间也耽误了工作,提出来吧,运气好你会碰上过来人。 本帖欢迎有经验者大力相助有困难的伙伴, 教学相长,估计日后也有可能你自己会碰上同样的难题。 本帖不接受任何作业帖,与工作项目上无关的帖子, 这类帖子将一律删除。
【CBM666 编程英文没难度】 一般编程【英文非常重要】, 但不是必须的 英文难在哪? 它就难在文法, 但是编程不需要你懂文法, 重点在牢记单字拼写, 至少记住它的【长相】, 一看就能认识它即可,一看就怕, 一看就躲, 对自己没信心 永远学不好编程。 编程中经常见到的 经常使用的, 也不过就是那几百个单字, 一天背几个单字, 一个月下来你能背几个?就只看你的IQ 只看你自己的恒心与努力罢了. 平时更需要多写代码 多看代码 一回生两回熟, 碰上陌生的就做笔记 金山词霸搜索网址: http://tieba.baidu.com/mo/q/checkurl?url=http%3A%2F%2Fwww.iciba.com%2Ftransparent&urlrefer=2e5b8a1adf8c4f5d0371fe071e0e7de3 (这是查询transparent单字的翻译示例) 百度词典搜索网址: http://tieba.baidu.com/mo/q/checkurl?url=http%3A%2F%2Fdict.baidu.com%2Fs%3Fwd%3Dtransparent&urlrefer=362ea0808da2035dfe34d1fc457fc146
【CBM666 vb6操作外部程序】 很简单的一个小动作, 但是如果能【 举一反三】加以应用, 它就不再是简单的东东.'添加 Command1 Command2 Option Explicit '强制变量必须声明 Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long 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 SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) Const WM_SETTEXT = &HC '常量宣告,不用背,知道它放在那里把它找出来复制粘贴进代码就得了 Dim Phwnd&, TextHwnd& '变量定义 Private Sub Form_Load() Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2 '将窗体移动到屏幕中心 Call Shell("cmd /c notepad", vbHide) '隐藏DOS窗口打开记事本 SetWindowPos Me.hwnd, -1, 0, 0, 0, 0, 3 '将窗口置顶 End Sub Private Sub Command1_Click() '利用窗口标题 [无标题 - 记事本] 找到记事本的句柄 Phwnd = FindWindow(vbNullString, "无标题 - 记事本") TextHwnd = FindWindowEx(Phwnd, 0, "Edit", vbNullString) '发送 CBM666 文字串改变窗口的标题 If TextHwnd <> 0 Then SendMessage TextHwnd, WM_SETTEXT, 0, ByVal "添加文本内容 CBM666" End Sub Private Sub Command2_Click() '利用窗口标题 [无标题 - 记事本] 找到记事本的句柄 Phwnd = FindWindow(vbNullString, "无标题 - 记事本") If Phwnd <> 0 Then SendMessage Phwnd, WM_SETTEXT, 0, ByVal "改变标题 CBM666" End Sub
【CBM666 ASC码列表】 MsgBox Asc("A") '将返回Asc码 65 MsgBox Chr(65) '将返回字符 A MsgBox Hex(65) '将返回十六进制 41 MsgBox Asc("a") '将返回 97 MsgBox Chr(97) '将返回 a MsgBox Hex(97) '将返回 61
【CBM666 飞舞的小天使】 10年前的代码 抛砖引玉 供新手练习 Esc键 或 Ctrl + F9 或 Shift + F10 退出程序 '本代码将可学习到下列小技巧 'CBM666 制作 '1.获取最下面任务栏的高度,窗体随时保持置顶层 '2.多张图片组合成动画 '3.如何制作不规则并且半透明的窗体 '4.如何控制动画在桌面上 上下左右 碰壁折返 '5.如何用API转换路径为短路径 '6.如何循环播放背景音乐 '7.全局键盘事件如何检测 示例使用 Esc键 或 Ctrl + F9 或 Shift + F10 退出程序 '8.自定义图像数组控件装载12张图片,播放动画可以提速并避免不停的LoadPicture减低内存耗用 Option Explicit '***************************************** '播放音乐使用的API Dim Pic(12) As StdPicture '定义12张图片为标准图片 Private Sub Form_Load() On Error Resume Next Timer1.Interval = 50: Timer1.Enabled = False TaskBarHeight = GetTaskbarHeight '获取任务栏的高度 '******************************************* For i = 1 To 12 '将12张图片放入自定义的图像框内 Set Pic(i) = LoadPicture(AppDisk & "Image\" & "Angel" & CStr(i) & ".gif") Next i SongName = AppDisk & "Music\I_Love.mid" '将路径与歌曲名赋值给变量SongName Call PlayMusic '调用副程序开始播放音乐 TransColor = vbBlue '定义蓝色为透明色 With Me '窗体定义属性 .BorderStyle = 0 '窗体无边框 .Caption = "" '窗体标题清除 .BackColor = TransColor '窗体背景色设置为透明色 .Picture = Pic(1) '先将Pic(1)这张图片当窗体背景 .Width = 96 * 15 '窗体宽度 .Height = 80 * 15 '窗体高度 End With Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2 '窗体居中 AniCount = 1: LR = True: UD = True '宣告 上下 左右 并定义图片由第一张开始播放 Call TM(Me.hwnd, 130, TransColor) '让窗体屏蔽掉透明色 并让它半透明 Timer1.Enabled = True '启动定时器 Me.Caption = "飞舞的小天使" End Sub Private Sub Form_Unload(Cancel As Integer) On Error Resume Next Erase Pic '清除数组 Controls.Remove ("Timer1") '卸载线上添加的定时器Timer1 Call CleanMemory '清除内存 Me.Move Screen.Width '将窗体移动到屏幕外 Call ReleaseTrans(Me.hwnd) '释放影像占用内存 Call StopMusic '停止播放音乐 Set Angel = Nothing '清除窗体占用内存 End Sub Private Sub Timer1_Timer() '利用定时器控件改变窗体图片并移动位置 On Error Resume Next If GetForegroundWindow <> Me.hwnd Then SetWindowPos Me.hwnd, -1, 0, 0, 0, 0, 3 '设定总在最前 Me.Picture = IIf(LR, Pic(AniCount), Pic(AniCount + 6)) AniCount = IIf(AniCount + 1 > 6, 1, AniCount + 1) '如果LR变量为True(真),窗体的左边座标是一次加100缇向右移动 ; 如果LR变量为False(假),窗体的左边座标是一次减100缇向左移动 Me.Left = IIf(LR, Me.Left + 100, Me.Left - 100) '如果窗体的左边界值小於等於 0 , 或窗体的左边界值大於或等於 屏幕的宽度减去窗体的宽度,则LR左右将反向,否则维持原来的方向不变换 LR = IIf(Me.Left <= 0 Or Me.Left >= Screen.Width - Me.Width, Not LR, LR) '如果UD变量为True(真),窗体的顶部座标是一次加75缇向下移动 ; 如果UD变量为False(假),窗体的顶部座标是一次减75缇向上移动 Me.Top = IIf(UD, Me.Top + 75, Me.Top - 75) '如果窗体的顶部边界值小於等於 0 , 或窗体的顶部边界值大於或等於 屏幕的高度减去窗体的高度,则UD上下将反向,否则维持原来的方向不变换 UD = IIf(Me.Top <= 0 Or Me.Top >= Screen.Height - Me.Height - TaskBarHeight, Not UD, UD) If GetAsyncKeyState(vbKeyEscape) Or (GetAsyncKeyState(vbKeyControl) And GetAsyncKeyState(vbKeyF9)) Or (GetAsyncKeyState(vbKeyShift) And GetAsyncKeyState(vbKeyF10)) Then Timer1.Enabled = False: Unload Me End Sub ,************************************** 模块 .bas 代码 Option Explicit Public Declare Function SetProcessWorkingSetSize Lib "kernel32" (ByVal hProcess As Long, ByVal dwMinimumWorkingSetSize As Long, ByVal dwMaximumWorkingSetSize As Long) As Long Public Declare Function GetCurrentProcess Lib "kernel32" () As Long Public Declare Sub SetWindowPos Lib "USER32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) Public Declare Function GetForegroundWindow Lib "USER32" () As Long '检测置前窗口使用的API Public Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long Public Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long '************************************************************************** 透明窗体用到的API Public Declare Function GdiTransparentBlt Lib "gdi32" (ByVal hdc1 As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal W1 As Long, ByVal H1 As Long, ByVal Hdc2 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal W2 As Long, ByVal H2 As Long, ByVal Color As Long) As Long Public Declare Function SetLayeredWindowAttributes Lib "USER32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long Const WS_EX_LAYERED = &H80000 Const GWL_EXSTYLE = (-20) Const LWA_ALPHA = &H2 Const LWA_COLORKEY = &H1 Public Declare Function GetWindowLong Lib "USER32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Public Declare Function SetWindowLong Lib "USER32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long '**************************************** Public Declare Function SystemParametersInfo Lib "USER32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long Public Const SPI_GETWORKAREA = 48 Public Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Public Rec As RECT '*************************************** Public Declare Function GetAsyncKeyState Lib "USER32" (ByVal vKey As Long) As Integer Public Const vbKeyAlt = vbKeyMenu 'VB忽略了它 我们自己补上 Public AppDisk$, SongName$, OldSong$ Public TransColor&, TmLevel&, NowLevel&, LvStep%, UD As Boolean, LR As Boolean Public i&, X1&, Y1&, Rtn&, TaskBarHeight&, AniCount& '变量宣告与定义变量型态 Sub Main() If App.PrevInstance Then MsgBox "本程序已运行中!", vbCritical, "飞舞的小天使": End AppDisk = GetShortName(IIf(Right(App.Path, 1) = "\", App.Path, App.Path & "\")) Angel.Show End Sub Public Function GetTaskbarHeight() As Long '获取最下面那排任务栏占用的高度 调用涵数 '获取最下面任务栏的高度 On Error Resume Next Dim lRes As Long Dim RectVal As RECT lRes = SystemParametersInfo(SPI_GETWORKAREA, 0, RectVal, 0) GetTaskbarHeight = ((Screen.Height / Screen.TwipsPerPixelX) - RectVal.Bottom) * 15 End Function '*********** 让窗体透明并且屏蔽颜色 Public Sub TM(ByVal Phwnd As Long, Tlevel As Long, Optional TColor As Long = -1) On Error Resume Next Rtn = GetWindowLong(Phwnd, GWL_EXSTYLE) Rtn = Rtn Or WS_EX_LAYERED SetWindowLong Phwnd, GWL_EXSTYLE, Rtn If TColor >= 0 Then SetLayeredWindowAttributes Phwnd, TColor, Tlevel, LWA_COLORKEY Or LWA_ALPHA '将扣去窗口中的指定颜色背景 Else SetLayeredWindowAttributes Phwnd, 0, Tlevel, LWA_ALPHA End If End Sub Public Function GetShortName(ByVal sLongFileName As String) As String '获取文件短路径 On Error Resume Next Dim lRetVal&, sShortPathName$ sShortPathName = Space(255) Call GetShortPathName(sLongFileName, sShortPathName, 255) If InStr(sShortPathName, Chr(0)) > 0 Then GetShortName = Mid(sShortPathName, 1, InStr(sShortPathName, Chr(0)) - 1) Else GetShortName = Trim(Mid(sShortPathName, 1)) End If End Function Public Sub ReleaseTrans(ByVal Phwnd As Long) '释放影像内存 On Error Resume Next Rtn = GetWindowLong(Phwnd, GWL_EXSTYLE) Rtn = Rtn And Not WS_EX_LAYERED SetWindowLong Phwnd, GWL_EXSTYLE, Rtn End Sub Public Sub StopMusic() '停止播放音乐 On Error Resume Next mciSendString "stop " & OldSong, vbNullString, 0, 0 mciSendString "close " & OldSong, vbNullString, 0, 0 End Sub Public Sub PlayMusic() '播放音乐的副程序 On Error Resume Next If Dir(SongName) <> "" Then mciSendString "open " & SongName & " type mpegvideo", vbNullString, 0, 0 mciSendString "play " & SongName & " repeat", vbNullString, 0, 0 OldSong = SongName End If End Sub Public Sub CleanMemory() '清除内存 SetProcessWorkingSetSize GetCurrentProcess, -1, -1 End Sub
【CBM666 请教农业方面的人才】 近日在规划一份报告提交县政府 奈何本人对农业方面的知识还是欠缺, 因此迟迟无法提交规划书, 祈请【农业】方面专家提供一些宝贵的经验知识 谢谢。 报告重点: 【农业智能化监控管理与科技应用发展】
【CBM666 请吧主出面答复】 本人目前时间富余 有心再次为广大吧友提供帮助 本人已申请大吧主 但是吧主迟迟未处理 请答复质疑 这是本人申请吧主 百度的答复: 您好,很遗憾的通知您,您在vb吧提交的吧主申请因吧主长时间未处理未被通过,如果您对此有疑问,请直接与该吧吧主联系。 如果你认为 本人能力不够 或你不愿意本人为广大吧友提供帮助 或其它原因 请直接拒绝 而不是不处理
【CBM666 支持B4A】 B4A目前在国内使用的人不多,但不代表它不行,而是一堆人还没发现宝贝罢了, 只要有Basic VBA .ASP .net 编程经验的人立马入门, 然后再逐步加强 多多实践即可
【CBM666第一次提问有关Bridge2.3】 请教各位 Bridge2.3 我一直运行正常, 现在突然闪退, 请问有哪位能正常运行的, 请将使用的类库版本截图我看看 谢谢
【CBM666 您对机器人了解有多少】 最近帮人开发了机器人控制 被忽悠了 只怪我一向太信任人 红包竟然是【10元】 大家笑吧。。。。 在中国 机器人只不过是噱头 玩玩的玩具罢了, 尤其是【智能型】再过N年才可能不是【做梦】 但是别忘记, 通信控制理念完全是成熟的, 机器人在工业上的应用就是 电机与汽缸等连结动作, 只要搞懂通讯技术,VB6 就是掌握 mscomm winsock 即可完成一系列的动作.
【CBM666 我对贴吧收费的看法】 首先我先表态 我100%完全赞同 【收费】 刚才去修了电风扇 看着师傅汗流浃背 但是还是没修好, 我还是给了他10元买瓶啤酒喝,聊表谢意. 刚回到家 有感而发 特发此帖 发发牢骚 一.我最讨厌看到的就是 任何一个问题帖子 总是跟着一堆 有偿服务的人, 不管有没难度 是否花时间, 就是要收 费才回答, 我只能说 鄙视 这类人, 贴吧不是菜市场, 漫天要钱 你穷疯了是吗 ?让外人看到那是天大的笑话与 无耻. 要收费 你自己学着我 边回答边打广告,明白吗?谁不爱钱啊, 我比你更爱,但得讲究方法!!! 二.那些平时不学习,不看书 临时抱佛脚的人, 肯定得付出代价, 有偿服务那是必须的, 就如同刚说的,我不学习电 机,风扇坏了求助于人, 难道我能叫别人干白活, 义务替你服务吗?写改软件不也一样花时间干技术活吗? 三.【结论】 对于那些伸手党 , 该收费而且狠狠的宰杀, 更不能廉价卖身 污蔑软件的价值. 我的做法是建立群 让他进来提问解决问题, 试着自己完成工作, 建群几十天,确实也有不少人学习了,自己解 决问题了, 你这是在帮助一个人不是吗?碰上扶不起的阿斗, 你再私下与他谈有偿服务, 就我所知几个群也是 这样的, 而不是在贴吧里 光天化日下,土匪作风死要钱才干活. 四. 强烈建议大小吧主, 对于那些几行代码就能解决 几分钟就能解决的问题, 还是死要钱才愿回答问题的那堆 【贴吧渣渣】踢出本吧, 别让外人笑话了.
【CBM666】提供英文盲认识学习编程与电脑常用单字 下载地址: http://tieba.baidu.com/mo/q/checkurl?url=http%3A%2F%2Fpan.baidu.com%2Fs%2F1boNcoJd&urlrefer=00cd22bbc26ea9faf45bd4a822eceab4CBM666 VB编程示例教材 小部份的截图样品访问链接 QQ:138449666 微信: cbm666-sam http://tieba.baidu.com/mo/q/checkurl?url=http%3A%2F%2Fxiangce.baidu.com%2Fpicture%2Falbum%2Flist%2F47a5fb2903bdcedd76f9915fc59608d858e99a0a&urlrefer=ce33aed61025f1a2d979827188818f33 CBM666毕设作业群 546479274
【CBM666 万事不求人 天助自助者 自己动手 丰衣足食】 凡事都一样 没必要掏腰包矮半截 去求人 自己动手 丰衣足食 If 平时不烧香临时抱佛脚事到临头求助者 Then Exit Sub Else MsgBox "欢迎进来 CBM666毕设作业群 546479274 免费指导" End If CBM666 VB编程示例教材 小部份的截图样品访问链接 QQ:138449666 微信: cbm666-sam http://tieba.baidu.com/mo/q/checkurl?url=http%3A%2F%2Fxiangce.baidu.com%2Fpicture%2Falbum%2Flist%2F47a5fb2903bdcedd76f9915fc59608d858e99a0a&urlrefer=ce33aed61025f1a2d979827188818f33
【CBM666 提醒那些毕设接单的人】 我现在手头上有两个【烂摊子】 我不说是谁 给你留点面子 自己自重自爱 钱是小事 耽误别人时间是大事 PP没长毛 破代码一看就知道 连这种水平也敢接毕设的单, 你不是把别人前途当儿戏耍吗? 代码越看越恼火 没经验就别乱接单 自己要有自信再接单 不是退钱就完事 小心哪天惹火烧身
【CBM666 协助解决毕设与作业难题】 2016/05/12 21:00 正式建群 目前本群就我一人 欢迎加群 1. 本群 主要是学生之间彼此可以互相帮助 , 交换做过的作业 , 本人随时抽空指导 2. 本人教材上面有1000个代码 类似的可以免费供应 自己再行修改 不懂的可以提问 3. 热烈欢迎 本VB吧真正在为人民服务的 【罗老师】进群为高级顾问 4. 只发截图 自己不写代码的人 一律T , 不要求你代码的正确性 只看你自己有没有动手 5. 代做者谢绝进群 , 本群非菜市场 CBM666 VB编程示例教材 小部份的截图样品访问链接 QQ:138449666 微信: cbm666-sam http://tieba.baidu.com/mo/q/checkurl?url=http%3A%2F%2Fxiangce.baidu.com%2Fpicture%2Falbum%2Flist%2F47a5fb2903bdcedd76f9915fc59608d858e99a0a&urlrefer=ce33aed61025f1a2d979827188818f33
【CBM666 敬祝全天下的母亲一生健康幸福快乐】 CBM666 VB编程示例教材 小部份的截图样品访问链接 QQ:138449666 微信: cbm666-sam http://tieba.baidu.com/mo/q/checkurl?url=http%3A%2F%2Fxiangce.baidu.com%2Fpicture%2Falbum%2Flist%2F47a5fb2903bdcedd76f9915fc59608d858e99a0a&urlrefer=ce33aed61025f1a2d979827188818f33
【CBM666 拟采购批量监控设备】 社区监控系统采购摄像头等设备 有意向者请联系我 QQ: 138449666 微信: cbn666-sam
【CBM666 社区监控项目有兴趣的来】 QQ 138449666 微信 cbm666-sam
【CBM666 编程员不值钱了】 不管你使用啥语言 编写程序糊口的就是【编程员】 你辛辛苦苦学了N年的编程 掌握了一定的技巧 用在特定专业需求上面 或许这还值钱, 用在一窝蜂的网络游戏编程也能赚钱 也算值钱, 其它一般软件就是买包烟 吃吃卤肉饭的下场了。。。。 原因是啥?? 一些编程员作践自己 猪99戒 下马威的客人。。。软件身价可以说一文不值了 去年2000-5000的毕设我还接了几个单 今年碰上10几个 不说高价 就几百上千的 都跑得比飞的还快 昨天一个学生 我也体谅理解学生困难 原本1000元的工作量 连要求他替我买张成都到长沙320元的火车票算回报 哈哈哈两下就人间蒸发了 估计有人几十元就接他的单了 还好我不靠这吃饭 退休了打发时间罢了 但是却感到极度的悲哀 为啥编程员沦落到这地步 只能说【作践自己】的一堆编程员搅浑了大水缸 CBM666 VB编程示例教材 小部份的截图样品访问链接 QQ:138449666 微信: cbm666-sam http://tieba.baidu.com/mo/q/checkurl?url=http%3A%2F%2Fxiangce.baidu.com%2Fpicture%2Falbum%2Flist%2F47a5fb2903bdcedd76f9915fc59608d858e99a0a&urlrefer=ce33aed61025f1a2d979827188818f33
【交流】【CBM666 制作上位机与PLC或单片机连线应用软件】 有需要或有疑问的的朋友 , 请与我联系 QQ: 138449666 微信: cbm666-sam
【闲聊】【CBM666 初来贵吧 请多赐教】 专业工业自动化 擅长编程 上位机软件配套PLC或单片机 初来乍到 盼指教 谢谢!
【CBM666 给VB吧里代做党的温馨提醒】 【首先 我先声明 我不反对也不排斥代做党 因为我也是代做党 方式与你们不同罢了】 在吧里随时随地都能见到你们这些人 但基本上从来就没见过你们给过帮助 或许偶尔一个点到为止的小意思 我没说错吧??? 给你们几点建议: 一.既然你们能代做 那就表示你们也有一定的水平 否则那就是坑爹 既然有能力为啥不提供帮助 ?? 短短几行代码就能搞定的问题 甚至于一行代码就OK的问题 你们也要代做,我说的这些并不夸张 大家有目共睹. 二.我说过 我也是代做党 但你们从来不会见过我发信息有偿代做 即使我当大吧主时 我连群里拉人 任何广告我都以身作则不敢打 即使打广告也是 【暗示性】的,或吧里认可的签名图片来打广告 一样的大家有目共睹, 建议你们适当的给与帮助 多回答一些问题 不要就等着那些无助的人不得已的捐献 三.上面说到【捐献】我也是代做党 但没明显的打过广告, 而且因为我到处帮人 我得到的代做收益不是你们的几十元几百元, 我是几千元几万元 因为人家信得过我, 明白了吗? 我的群要收费 我的教材要卖钱 我与你们一样都是【生意人】但是我不是不奉献获得的,为啥会有人愿意花几百元加入我的收费群 花钱买我的教材, 那是因为我做的事 他们看在眼里 话说那么多 结论就是希望你们这些人多给于吧里的人帮助 而不是一句代做 二句有偿, 在吧里的同志面前, 大家心里会评价 会心里有数 说那么多【废话】 心里有数的话 自己调试一下心态吧. 【打广告时间到了 下面就是我的广告】
【CBM666 征求长沙合作伙伴】 本人目前刚到长沙 拟开发智能家居, 录像监控以及所有相关软件系统的市场, 在长沙的同志有兴趣者可以Q我 138449666
【CBM666 VB编程示例教材更新通知】 感谢932位同志的支持 现在新改版了, 抱歉人太多无法一一通知 , 麻烦已购买的同志小窗Q我 谢谢 QQ: 138449666 新增加了100多个代码 包括我这两天才开始印刷的彩页, 它的制作方法列入教材了
【CBM666 请教 本地Access 数据库批量上传SQL 谢谢】 请教 批量上传本地Access数据库的一张表内所有的数据 批量上传到SQL的语句 谢谢 不必考虑数据重复问题
【CBM666 请教 SQL 数据同步备份问题 谢谢】 SQL 数据添加问题 我就卡在这里了 请教各位高招 谢谢 我用循环能够完美解决 大问题是 效率问题 两个表 RS RS2 结构完全一样 要将RS2数据全部添加到RS 但是如果RS表里面 ID 已存在则跳过 不能添加 感谢各位帮助
【CBM666 VB6 模拟测试】 初期只发布【控件篇】 欢迎考考自己对VB6 基础控件了解多少?? 下载地址: http://tieba.baidu.com/mo/q/checkurl?url=http%3A%2F%2Fpan.baidu.com%2Fs%2F1sjBXnfZ&urlrefer=e97728502034b0c9bd8c87e981f951b2
【CBM666 注册表演示红绿灯】 下载地址: http://tieba.baidu.com/mo/q/checkurl?url=http%3A%2F%2Fpan.baidu.com%2Fs%2F1mgqTJV6&urlrefer=8fcec48841381bce1ede2df3a7501618
【CBM666 有偿求助修改DZ动力论坛网页设置】 CBM666 梦天空 VB 编程论坛 http://tieba.baidu.com/mo/q/checkurl?url=http%3A%2F%2Fcbm666.net%2F&urlrefer=e3fd725043ac32ac14e2f4341d527b26 求协助修改特殊设置 谢谢
【CBM666 VB编程论坛 梦天空 重新开锣了】 昨天买的域名与空间 今天开锣了 欢迎注册 共同学习 共同进步
【CBM666 VB6编程示例教材通知】 感谢第一批已购买本教材的99位朋友 如需要快递单号的麻烦Q我, 人数众多 无法一一通知 抱歉,
【CBM666 语音播放英文单字词】 说简单是简单 真要研究还不简单 竟然搞了我两天才搞懂 用户安装了微软TTS或金山或飞讯等语音库 都会在注册表内 路径是 HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Speech 为了造福一堆 【英文盲】在本人的教材里特地加上了 编程常用英文单字 配上自动朗读拼音 学习更加容易了 但是一个人能力与时间毕竟有限 特在此求助 帮忙写出常用的英文单字词 谢谢各位大力相助 有多少算多少 滴水成渠 将整理为文档 发布共享 谢谢
【CBM666 删帖放假】 1. 本人自即日起10天内不删任何帖子 对不起他老娘老姊老妹的猥琐签名图片 本人才会删帖封号 其他小吧想继续删帖的 当然不会反对 呵呵 吧规 对于一堆人都是废纸一张 贴上又有啥用 ??? 2. 那些发作业贴 发到处都能摆渡到的菜鸟帖的人 你们帖子被删了 别再私信我 更不用Q我 不会是我删的 3. 那些嫌VB吧乱的人也别找我 因为删帖也不是 不删也不是 你来当吧主好了
【CBM666 昨夜的一场梦】 竟然会梦见30多年前真实经历过的事。。。。。 给从事工控业的人 提个醒: 眼睛没到位的地方 小手勿到。 我个人从事工控业30余年 一生中经历的最大灾难 运气不错, 还好不是380 否则回不来了。 话说在一家羽毛厂安装设备 还在调试阶段 许多安全措施还没到位,加上当年年轻没啥经验, 为了调整机柜里的配件, 拟将控制箱移前一些,竟然笨到双手伸后面往前拖动机箱, 只记得老天给我的神力,我竟然还能抬脚踹机柜将身体弹开, 醒来后躺在医院病床上, 幸亏是220 否则380肯定挂了.
【温馨提示---贴图党】 最近一大堆的人 来个标题 求助大神。。。。然后就是几张需要放大镜才能看清的图片 需要扭着脖子才能看的图片 思想换位 你浏览任何网页要你扭着脖子 你干不干??? 发作业求教求助 你要讲究点技术 让人觉得你是在学习知识 解决问题 自己要劳动一下 整理作业内容 手敲键盘将重点表达出来 别让人感觉你是在应付作业 表现你的诚意 自然会有人帮你 更【不会】被删帖. 虽然N多的帖子不是我一个人删的 但是矛头一律指向我 还声称吧主不负责乱删帖 只要不删他们的帖 那就是好吧主 哈哈哈哈 真是滑天下之大讥。。。。。
【VB吧不是菜市场】 都乱来了 再不管制 整个吧已经轰动全中国VB论坛了, 百度VB吧是唯一【群起】漫天叫价的专业论坛了, 有那闲时间就去猪八戒网逛逛, 因为那里不是论坛 而是公开的市场. 伸手党毫无疑问 非收费不可 而且还要痛宰 但是请你们技术点 要交易一律【私信】 所有【商店】 本人今天全部通删 不用去猜谁删的 就是我本人删的 特此公告.
【CBM666 循环播放图片】 最近不少人提问循环播放图片或音乐 本代码完全可以适用 先理解就能变通
【CBM666与工控业界的同伙探讨一种算法】 串口每秒采集一次温度 (因为是在特定抽真空的容器内,因此不必考虑突波) 目的是采集每一时间段(600秒)之间 最高与最低温度差必须在0.5度之内 即算是达标区间 结束测试 打印达标的区间 最低几度最高几度 所谓区间段就是 1秒-601秒之间的温度数据 2秒-602秒之间的温度数据 3秒-603秒之间的温度数据 4秒-604秒之间的温度数据....... 我已写好代码 我认为它是个很有效率的算法 但也未必见得, 因此特提出来 供大家探讨 共同求进步为真
【CBM666的世界杯倒计时】 本代码学习重点: 1.不规则无边框窗体透明与拖动 2.GIF图片组合动画 3.WMP自动循环播放 + FLASH 演绎多媒体效果 4.窗体随时保持置顶状态 转载请注明来源出处作者: CBM666
【百度管理员改正下吧】 你的倒计时时间是 第一场开赛时间 开幕式 是前2小时
【签名图片请自重】 那些带猥亵的签名图片 百度让你通过使用 我可不让你通过 我不但删你帖还封你号 不服的话请尽管去申诉
【CBM666 聘用北京VB兼职员】 2014/3/1 本人开始动手开发多语种 汽相层析仪控制系统 为期约2个月 这两个月随我学习交接整套系统的开发 以兼职方式【上班】 待遇还算不错,限北京当地人员 等我开发完成离开后 必须继续留在该单位 负责软件更新维护与升级. 有意者Q我 138449666 水平程度不在中等以上者就别找我了.
【CBM666请教PictureBox的AutoSize属性】 探讨PictureBox 的 AutoSize 属性 请教那位有实际测试的 请提供经验 谢谢 我正在写 截取特大型图片的示例教材,碰上此疑问点,只想完美解决. 截取163.com特大型网页的整个图片 非得设定高度在112000 Twip 不可, 使用autosize只能抓到实际网页图片约1/3
$(ti) $(co)
【宝贝下载专区】 有好的东东 往这里丢 exe不开源的 免贴
【VB 吧有关发帖回帖相关注意事项通告 补充】 一,凡是发 作业 自己不动手贴上代码要求修改者 一律立马删帖 二.凡是发问 VB6如何安装的 一律 立马 删帖
【CBM666 进来逛逛】 晕死...........孤陋寡闻 竟然不知道还有个 VB6.0 吧
【CBM666 随机数概念】 【有许多的同志没有完全了解 Rnd 随机乱数的真正用法】 这篇帖子是以前发表的, 我遍寻不着,特此重贴. '******************************************************* RND 初始值是小于1 后面带好几位小数点,因随机数一般不会用到小数点,所以加上Int 将初始值整数化 Randomize 不加上这行,则每次所得到的一批数值都是依 "固定顺序" 排列的 "相同" 乱数. Rnd * 100 这行的正确解释是 从 0 起算, 得到从 0-99 总共100个的随机数. (但得不到 100 这个数) 1.从 1 到 100 之间取个随机数, 公式如下: 公式可以这样理解: 最小值=1 最大值=100 xx=int(Rnd * (最大值-最小值+1)) + 最小值. 代码: xx=int(Rnd * (100-1+1)) + 1 2.从 10 到 100 之间取个随机数, 公式如下: 公式可以这样理解: 最小值=10 最大值=100 xx=int(Rnd * (最大值-最小值+1)) + 最小值. 代码: xx=int(Rnd * (100-10+1)) + 10 3.从 101 到 500 之间取个随机数, 公式如下: 公式可以这样理解: 最小值=101 最大值=500 xx=int(Rnd * (最大值-最小值+1)) + 最小值. 代码: xx=int(Rnd * (500-101+1)) + 101
【CBM666 罕见却实用的一个API】 添加 Command1 Text1 测试 VB计算文字串的长度 无论你是字母,数字,汉字,或符号,全角,半角....一律算一个字符 因此当有需要逐一循环整个字符串时将会出错,汉字与全角应该是占用两个字节的 这个API可以给你正确的字节数. Private Declare Function LstrLen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long Dim StrLen& Private Sub Command1_Click() StrLen = LstrLen(Text1.Text) MsgBox StrLen End Sub
【CBM666 的富尔豪斯纸牌游戏】 FullHouse 富尔豪斯纸牌游戏 初期单机版 人机对战 第二期局域网多人对战 第三期广域网多人对弈 拭目以待吧..... 那位有好的思路与宝贵意见 敬请多多赐教.......
【CBM666 半透明不规则窗体屏蔽指定背景颜色】 【摘录自 CBM666 VB编程示例教材_窗体篇】 Option Explicit '******************************** 拖动窗体用到的API Private Declare Function SetCapture Lib "USER32" (ByVal hwnd As Long) As Long Private Declare Function ReleaseCapture Lib "USER32" () As Long 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 '******************************** 窗体透明用到的API与常量宣告 Private Declare Function GetWindowLong Lib "USER32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "USER32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function SetLayeredWindowAttributes Lib "USER32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long Const WS_EX_LAYERED = &H80000 Const GWL_EXSTYLE = (-20) Const LWA_ALPHA = &H2 Const LWA_COLORKEY = &H1 '************************************** 变量声明与型态定义 Dim TransColor&, Rtn&, AppDisk$, ImageWidth&, ImageHeight& Const MILLICMETERCELL = 26.45836 Private Sub Form_Load() '本地路径判别\后赋值给变量AppDisk AppDisk = IIf(Right(App.Path, 1) = "\", App.Path, App.Path & "\") TransColor = vbBlue '指定透明色为蓝色赋值给变量TransColor Me.BackColor = TransColor '窗体的背景色设定为透明色 Me.BorderStyle = 0: Me.Caption = "" '设定窗体无边框无标题栏 Me.Picture = LoadPicture(AppDisk & "lamp.bmp") '载入本地路径下的图片当窗体背景 Call GetPictureSize(Me.Picture) '调用副程序GetPictureSize获取窗体背景图片的宽度与高度 '获取到的宽高度是像素值 乘上15转为缇,当作窗体的宽度与高度 Me.Width = ImageWidth * 15: Me.Height = ImageHeight * 15 Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2 '窗体居中 '使用API SetLayeredWindowAttributes与常量让窗体透明并屏蔽调指定的透明色 Rtn = GetWindowLong(hwnd, GWL_EXSTYLE) Rtn = Rtn Or WS_EX_LAYERED SetWindowLong hwnd, GWL_EXSTYLE, Rtn '**** 屏蔽透明色并让它半透明150, 改为 255即不透明 SetLayeredWindowAttributes hwnd, TransColor, 150, LWA_COLORKEY Or LWA_ALPHA End Sub Private Sub Form_Click() '窗体点击事件 Me.Move Screen.Width '移到屏幕外免得下面一行释放影像内存会闪黑 Call ReleaseTrans(Me.hwnd) '释放影像内存 Set Form1 = Nothing '释放窗体内存 End '结束退出程序 End Sub Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) If Button = 1 Then Call DragKj(Me.hwnd) '当鼠标左键按下调用副程序拖动窗体 End Sub Public Function GetPictureSize(ByVal P As Picture) As Integer ImageWidth = Int(P.Width / MILLICMETERCELL + 0.5) '获取位图的宽度 ImageHeight = Int(P.Height / MILLICMETERCELL + 0.5) '获取位图的高度 End Function Public Sub ReleaseTrans(ByVal Phwnd As Long) '释放影像内存 On Error Resume Next Rtn = GetWindowLong(Phwnd, GWL_EXSTYLE) SetWindowLong Phwnd, GWL_EXSTYLE, Rtn And Not WS_EX_LAYERED End Sub Private Sub DragKj(HwndKj As Long) '拖动窗体 On Error Resume Next Screen.MousePointer = 5 '改变光标的样式,使用VB预设的5号图标 Call ReleaseCapture '释放捕捉 Call SendMessage(HwndKj, &HA1, &H2, 0&) '发送鼠标消息 Screen.MousePointer = 0 '恢复原始光标的样式 End Sub 代码使用到的图片 下载Lamp.bmp 放在程序同路径 App.Path
【CBM666 枚举窗体内部所有控件】 枚举窗体内部所有控件 尤其是自适应窗体控件 或其它用途... Option Explicit '强制宣告定义变量 Dim Ctr As Control Dim aa$ Private Sub Form_Click() On Error Resume Next Me.Cls '清除画面 For Each Ctr In Me.Controls '枚举所有控件成员 aa = Ctr.Name '将控件名称复制给变量aa '如果本控件是数组控件(包含索引值) 则变量aa将再连接括号与索引值 If Ctr.Index >= 0 Then aa = aa & "(" & CStr(Ctr.Index) & ")" Print aa '打印本控件名称 Next End Sub
【CBM666 简易快速读写注册表】 在很多时候我们必须将一些值保存以便于下次程序运行时调取, 可以使用文件来保存,现在我们不用文件 直接将内容保存到注册表内, 保密性质的话 自己在写入之前先加密. '添加 Command1 Command2 Option Explicit Dim aa$ '******************************************************************** '直接使用VB指定默认的注册表路径 不使用API 'HKEY_CURRENT_USER\Software\VB and VBA Program Settings 注册表所在位置 '******************************************************************** Private Sub Form_Load() Command1.Caption = "写入注册表" Command2.Caption = "读取注册表" End Sub Private Sub Command1_Click() '屏幕宽度与高度写进注册表 '调用副程序SaveRegData将用户名与密码写进注册表 Call SaveRegData("密码保存", "设定值", "用户名", "CBM666") Call SaveRegData("密码保存", "设定值", "密码", "123456789") MsgBox "已将用户名与密码保存到注册表!", vbOKOnly, "注册表密码读写" End Sub Private Sub Command2_Click() '读取注册表的值 '调用副程序GetRegData将注册表保存的用户名与密码读出赋值给变量aa aa = GetRegData("密码保存", "设定值", "用户名") MsgBox "用户名:" & aa, vbOKOnly, "注册表密码读写" aa = GetRegData("密码保存", "设定值", "密码") MsgBox "密码:" & aa, vbOKOnly, "注册表密码读写" End Sub '保存函数所带的参数值到注册表里面 Public Sub SaveRegData(MainItem$, SubItem$, KeyStr$, SaveStr$) SaveSetting MainItem, SubItem, KeyStr, SaveStr End Sub '从注册表里面获取保存的内容 Public Function GetRegData(MainItem$, SubItem$, KeyStr$) As String GetRegData = GetSetting(MainItem, SubItem, KeyStr) End Function
【CBM666 的RGB取色】 添加 Command1 CommonDialog1 '摘录自【CBM666 VB编程示例教材 图像篇_窗体取色】 Option Explicit Private WithEvents Picture1 As PictureBox '自定义线上添加控件picture1的声明 Private WithEvents Picture2 As PictureBox '自定义线上添加控件picture2的声明 Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long Dim AppDisk$, MyHwnd&, MyHdc&, Red&, Green&, Blue&, ColorVal& '变量声明与型态定义 $=String文字型 &=Long长整型 Private Sub Form_Load() AppDisk = IIf(Right(App.Path, 1) = "\", App.Path, App.Path & "\") '判断本地路径的\ 赋值给变量AppDisk Set Picture1 = Me.Controls.Add("VB.PictureBox", "Picture1") '线上添加picture1控件 Picture1.BorderStyle = 0 '图片框picture1设定为无边框 Picture1.Visible = True '线上添加的控件默认为不可见 所以得加上这行让它 可见. Picture1.Move 5450, 7320, 4250, 495 '设定picture1的宽度与高度并移动到5450,7320的坐标位置 Set Picture2 = Me.Controls.Add("VB.PictureBox", "Picture2") '线上添加picture2控件 Picture2.BorderStyle = 0 '图片框picture2设定为无边框 Me.AutoRedraw = True '窗体自动重画为真 Me.Width = 9840: Me.Height = 8370 '定义窗体宽度与高度 (中间的冒号表示不换行,两行代码简化为一行) Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2 '窗体居于屏幕中心位置 Me.Picture = LoadPicture(AppDisk & "ColorSet.jpg") '本地路径下的ColorSet.jpg装载进窗体当背景图片 Command1.Caption = "选择图片" End Sub Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ColorVal = GetPixel(Me.hdc, X \ 15, Y \ 15) '使用API GetPixel 获取颜色十进制值 Call GetRGB '调用颜色十进制值转换为RGB的副程序 Me.Caption = CStr(ColorVal) & "--- R:" & CStr(Red) & ",G:" & CStr(Green) & ",B:" & CStr(Blue) '窗口标题显示颜色值 Picture1.BackColor = RGB(Red, Green, Blue) '将右下角的picture1 涂上当前鼠标指向的颜色同步刷新 End Sub Private Sub Form_Unload(Cancel As Integer) Controls.Remove ("Picture1") '移除动态添加的控件 Controls.Remove ("Picture2") ReleaseDC MyHwnd, MyHdc '释放影像内存 Set Form1 = Nothing '释放窗体占用内存 End '退出结束程序 End Sub Private Sub Command1_Click() On Error GoTo Errhandler ' 捕捉错误 With CommonDialog1 .DialogTitle = "打开图片" .DefaultExt = ".jpg" ' 设置默认的扩展名 .Filter = "所有支持的图片格式" & "(*.bmp;*.jpg;*.gif)|" & "*.bmp;*.jpg;*.gif)" .ShowOpen ' 显示"另存为"对话框 End With Picture2.Picture = LoadPicture(CommonDialog1.FileName) Me.Cls Me.PaintPicture Picture2.Picture, 5450, 60, 4250, 3188 Errhandler: If Err > 0 Then Exit Sub End Sub Sub GetRGB() '颜色十进制值转换为RGB的副程序 Red = (ColorVal And &HFF&) Green = (ColorVal And &HFF00&) \ 256 Blue = (ColorVal And &HFF0000) \ 65536 End Sub 代码使用到的图片 请保存为 Coloset.jpg效果图
【CBM666 给 110 公开的一封信】 本人是 110 会员, 失望 绝望 之余, 从此不再登录 110 http://tieba.baidu.com/mo/q/checkurl?url=http%3A%2F%2Fwww.110.com%2Fask%2Fquestion-1409252.html&urlrefer=e3f2c019e31b52c62d06652fdca4b207 我爸爸 昨晚不幸过逝, 心情悲愤到极点, 今天 我就想 喷饭..... 本人受骗上当数次了 只怪自己愚蠢 但是不为 钱 而是 气难消, 气的是 平头老百姓 没背景 没钱财 想伸张正义 铲奸除恶 那是做白日梦......
1
下一页