分享到新浪微博 分享到QQ空间 打印

[原创VB]可以在桌面上乱拖的小时钟

[原创VB]可以在桌面上乱拖的小时钟

小东西……不足过目……
经本人测试MS比你电脑时间慢一秒……不过如果对时间需要不太精确的话就算了……
全部用的PM造型……据说Copy来自某计数器……
PIC:
谁不怀念苏联,谁就没有良心;谁想回到苏联,谁就没有头脑.

Woodu.ME--从零开始的博客生活

TOP

只有一个不满意。就是图很“古典”............
  

TOP

好东西,收下了。有源代码么?
AF-06 Liberation -- Battle for liberty

TOP

唉……当然有了……
我这里还有6MB的VB6Mini呢……
谁不怀念苏联,谁就没有良心;谁想回到苏联,谁就没有头脑.

Woodu.ME--从零开始的博客生活

TOP

我也有,我问的是这个时钟的代码。
大牛(Woodo)能否将VB工程打包并公布?
谢谢了
AF-06 Liberation -- Battle for liberty

TOP

好……我准备下……
MS每次都是你要源代码= =|
谁不怀念苏联,谁就没有良心;谁想回到苏联,谁就没有头脑.

Woodu.ME--从零开始的博客生活

TOP

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 SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
Private Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Private Declare Function 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) 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 Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hWnd As Long) As Long
Private Declare Function WinExec Lib "kernel32" (ByVal lpCmdLine As String, ByVal nCmdShow As Long) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vkey As Long) As Integer

Private timerStr(0 To 5) As Integer
Private Sub exit_Click()
Unload Me
End
End Sub
Private Sub about_Click()
eds
End Sub
Function eds()
If Label3.Caption = "By WiNmAnYg0o1" Then
Label3.Alignment = 0
Label3.Caption = "联系我:LLJTSJ@Gmail.com 再选“关于”返回"
GoTo q
End If
If Label3.Caption = "联系我:LLJTSJ@Gmail.com 再选“关于”返回" Then
Label3.Caption = "By WiNmAnYg0o1"
Label3.Alignment = 1
GoTo Skip
End If
Skip:
q:
End Function


Private Sub Form_Load()
    Dim i As Integer
    '窗体最前显示
    With Form1
        SetWindowPos .hWnd, HWND_TOPMOST, 0, 0, 0, 0, Flag
    End With
    'DoTheStuff hWnd '透明窗体,把黑色的部分透明
   
    Timer1.Interval = 1000
    Timer1.Enabled = True
    Call Timer1_Timer '调用数字图片变换的过程,要不初始会显示默认时钟图片
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 1 Then
        Me.MousePointer = 15
        ReleaseCapture
        SendMessage Me.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
    ElseIf Button = 2 Then
    Me.PopupMenu Menucomm
    End If
    Me.MousePointer = 0
End Sub

Private Sub Label3_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 1 Then
        Me.MousePointer = 15
        ReleaseCapture
        SendMessage Me.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
    ElseIf Button = 2 Then
    Me.PopupMenu Menucomm
    End If
    Me.MousePointer = 0
End Sub
Private Sub Label2_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 1 Then
        Me.MousePointer = 15
        ReleaseCapture
        SendMessage Me.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
    ElseIf Button = 2 Then
    Me.PopupMenu Menucomm
    End If
    Me.MousePointer = 0
End Sub
Private Sub Label1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 1 Then
        Me.MousePointer = 15
        ReleaseCapture
        SendMessage Me.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
    ElseIf Button = 2 Then
    Me.PopupMenu Menucomm
    End If
    Me.MousePointer = 0
End Sub

Private Sub Picture1_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    '拖动窗体
    If Button = 1 Then
        Me.MousePointer = 15
        ReleaseCapture
        SendMessage Me.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
    ElseIf Button = 2 Then
    Me.PopupMenu Menucomm
    End If
    Me.MousePointer = 0
End Sub


Private Sub Picture2_Click(Index As Integer)

End Sub

Private Sub Timer1_Timer()

    Dim i As Integer
    Dim hourStr As String, minuteStr As String, secondStr As String

    hourStr = Hour(Time)
    minuteStr = Minute(Time)
    secondStr = Second(Time)
    timerStr(0) = IIf(Len(hourStr) = 2, Left(hourStr, 1), 0)
    timerStr(1) = IIf(Len(hourStr) = 2, Right(hourStr, 1), hourStr)
    timerStr(2) = IIf(Len(minuteStr) = 2, Left(minuteStr, 1), 0)
    timerStr(3) = IIf(Len(minuteStr) = 2, Right(minuteStr, 1), minuteStr)
    timerStr(4) = IIf(Len(secondStr) = 2, Left(secondStr, 1), 0)
    timerStr(5) = IIf(Len(secondStr) = 2, Right(secondStr, 1), secondStr)

    For i = 0 To 5
        Picture1(i).Picture = ImageList1.ListImages(timerStr(i) + 1).Picture
    Next i
End Sub


只能公布下代码了……所有代码……其他请自己备


Option Explicit

Public Declare Function 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) As Long
'常量
Public Const MF_BYPOSITION = &H400&
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = &H1
Public Const SWP_HIDEWINDOW = &H80
Public Const SWP_SHOWWINDOW = &H40
Public Const Flag = SWP_NOMOVE Or SWP_NOSIZE  '不移动和改变窗口大小
Public Const WS_EX_LAYERED = &H80000
Public Const GWL_EXSTYLE = (-20)
Public Const LWA_ALPHA = &H2
'拖动窗体的API
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const HTCAPTION = 2
Public Declare Function ReleaseCapture Lib "user32" () As Long
Public Const WM_NCLBUTTONDOWN = &HA1

Public Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags 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 Sub DoTheStuff(ByVal hWnd As Long)
    SetWindowLong hWnd, -20, &H80000 '设置透明,那些颜色为&H00000000&的变为透明
    SetLayeredWindowAttributes hWnd, 0, 0, 1
End Sub


有些没有用的
上面是模块
开头是FRM
谁不怀念苏联,谁就没有良心;谁想回到苏联,谁就没有头脑.

Woodu.ME--从零开始的博客生活

TOP

ERR。。。不是工程模块/_\
有工程文件么?
后来渐渐感觉到,这个世界要比想象中大很多,复杂很多……

TOP

有啊……不想发布啦……太麻烦了……
谁不怀念苏联,谁就没有良心;谁想回到苏联,谁就没有头脑.

Woodu.ME--从零开始的博客生活

TOP

哇哇哇哇哇!灌水。
我的目的是帮大牛改进一下啊!
后来渐渐感觉到,这个世界要比想象中大很多,复杂很多……

TOP

好啊……愿意接受……
谁不怀念苏联,谁就没有良心;谁想回到苏联,谁就没有头脑.

Woodu.ME--从零开始的博客生活

TOP

那你总得发工程文件啊/_\
AF-06 Liberation -- Battle for liberty

TOP

发吧.我也需要,大牛............
  

TOP

不发叫我怎么做改进?
大牛!求求您了!
AF-06 Liberation -- Battle for liberty

TOP

唉……没办法……
给你们啦~
表修改作者啦……
谁不怀念苏联,谁就没有良心;谁想回到苏联,谁就没有头脑.

Woodu.ME--从零开始的博客生活

TOP

十分感谢,开始为程序注入更多活力^_^
后来渐渐感觉到,这个世界要比想象中大很多,复杂很多……

TOP

OK我也在努力修改ing...
谁不怀念苏联,谁就没有良心;谁想回到苏联,谁就没有头脑.

Woodu.ME--从零开始的博客生活

TOP

很有创意的东东,只是图片有待改进哈,这个风格还欠点……

TOP

帮咱写写?
谁不怀念苏联,谁就没有良心;谁想回到苏联,谁就没有头脑.

Woodu.ME--从零开始的博客生活

TOP

咋又是程序?
修改失败。
提议:让程序的启动位置在右上角,并且进入系统后启动程序
后来渐渐感觉到,这个世界要比想象中大很多,复杂很多……

TOP