cbm666 cbm666
关注数: 28 粉丝数: 1,517 发帖数: 26,280 关注贴吧数: 4
【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 远程监控摄像头的概念】 远程监控摄像头 当今物流产业盛行的年代 到处可见得天眼, 估计大家都知道 都见过, 但是要用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操作外部程序】 很简单的一个小动作, 但是如果能【 举一反三】加以应用, 它就不再是简单的东东.'添加 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 飞舞的小天使】 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 我对贴吧收费的看法】 首先我先表态 我100%完全赞同 【收费】 刚才去修了电风扇 看着师傅汗流浃背 但是还是没修好, 我还是给了他10元买瓶啤酒喝,聊表谢意. 刚回到家 有感而发 特发此帖 发发牢骚 一.我最讨厌看到的就是 任何一个问题帖子 总是跟着一堆 有偿服务的人, 不管有没难度 是否花时间, 就是要收 费才回答, 我只能说 鄙视 这类人, 贴吧不是菜市场, 漫天要钱 你穷疯了是吗 ?让外人看到那是天大的笑话与 无耻. 要收费 你自己学着我 边回答边打广告,明白吗?谁不爱钱啊, 我比你更爱,但得讲究方法!!! 二.那些平时不学习,不看书 临时抱佛脚的人, 肯定得付出代价, 有偿服务那是必须的, 就如同刚说的,我不学习电 机,风扇坏了求助于人, 难道我能叫别人干白活, 义务替你服务吗?写改软件不也一样花时间干技术活吗? 三.【结论】 对于那些伸手党 , 该收费而且狠狠的宰杀, 更不能廉价卖身 污蔑软件的价值. 我的做法是建立群 让他进来提问解决问题, 试着自己完成工作, 建群几十天,确实也有不少人学习了,自己解 决问题了, 你这是在帮助一个人不是吗?碰上扶不起的阿斗, 你再私下与他谈有偿服务, 就我所知几个群也是 这样的, 而不是在贴吧里 光天化日下,土匪作风死要钱才干活. 四. 强烈建议大小吧主, 对于那些几行代码就能解决 几分钟就能解决的问题, 还是死要钱才愿回答问题的那堆 【贴吧渣渣】踢出本吧, 别让外人笑话了.
【CBM666 给VB吧里代做党的温馨提醒】 【首先 我先声明 我不反对也不排斥代做党 因为我也是代做党 方式与你们不同罢了】 在吧里随时随地都能见到你们这些人 但基本上从来就没见过你们给过帮助 或许偶尔一个点到为止的小意思 我没说错吧??? 给你们几点建议: 一.既然你们能代做 那就表示你们也有一定的水平 否则那就是坑爹 既然有能力为啥不提供帮助 ?? 短短几行代码就能搞定的问题 甚至于一行代码就OK的问题 你们也要代做,我说的这些并不夸张 大家有目共睹. 二.我说过 我也是代做党 但你们从来不会见过我发信息有偿代做 即使我当大吧主时 我连群里拉人 任何广告我都以身作则不敢打 即使打广告也是 【暗示性】的,或吧里认可的签名图片来打广告 一样的大家有目共睹, 建议你们适当的给与帮助 多回答一些问题 不要就等着那些无助的人不得已的捐献 三.上面说到【捐献】我也是代做党 但没明显的打过广告, 而且因为我到处帮人 我得到的代做收益不是你们的几十元几百元, 我是几千元几万元 因为人家信得过我, 明白了吗? 我的群要收费 我的教材要卖钱 我与你们一样都是【生意人】但是我不是不奉献获得的,为啥会有人愿意花几百元加入我的收费群 花钱买我的教材, 那是因为我做的事 他们看在眼里 话说那么多 结论就是希望你们这些人多给于吧里的人帮助 而不是一句代做 二句有偿, 在吧里的同志面前, 大家心里会评价 会心里有数 说那么多【废话】 心里有数的话 自己调试一下心态吧. 【打广告时间到了 下面就是我的广告】
【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 简易快速读写注册表】 在很多时候我们必须将一些值保存以便于下次程序运行时调取, 可以使用文件来保存,现在我们不用文件 直接将内容保存到注册表内, 保密性质的话 自己在写入之前先加密. '添加 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效果图
1 下一页