home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 3_2004-2005.ISO / Data / Zips / Desktop_In1726743312004.psc / Form1.frm < prev    next >
Text File  |  2004-03-31  |  11KB  |  382 lines
  1. VERSION 5.00
  2. Begin VB.Form Form1 
  3.    AutoRedraw      =   -1  'True
  4.    BackColor       =   &H00FF00FF&
  5.    BorderStyle     =   0  'None
  6.    Caption         =   "Form1"
  7.    ClientHeight    =   6135
  8.    ClientLeft      =   0
  9.    ClientTop       =   0
  10.    ClientWidth     =   3255
  11.    BeginProperty Font 
  12.       Name            =   "MS Sans Serif"
  13.       Size            =   8.25
  14.       Charset         =   0
  15.       Weight          =   700
  16.       Underline       =   0   'False
  17.       Italic          =   0   'False
  18.       Strikethrough   =   0   'False
  19.    EndProperty
  20.    LinkTopic       =   "Form1"
  21.    ScaleHeight     =   409
  22.    ScaleMode       =   3  'Pixel
  23.    ScaleWidth      =   217
  24.    ShowInTaskbar   =   0   'False
  25.    StartUpPosition =   3  'Windows Default
  26.    Begin VB.Timer Timer1 
  27.       Enabled         =   0   'False
  28.       Interval        =   200
  29.       Left            =   1080
  30.       Top             =   4260
  31.    End
  32. End
  33. Attribute VB_Name = "Form1"
  34. Attribute VB_GlobalNameSpace = False
  35. Attribute VB_Creatable = False
  36. Attribute VB_PredeclaredId = True
  37. Attribute VB_Exposed = False
  38. Option Explicit
  39. 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
  40.  
  41. Private Declare Sub ReleaseCapture Lib "user32" ()
  42.  
  43. Private Const CCM_FIRST = &H2000
  44. Private Const CCM_SETBKCOLOR = (CCM_FIRST + 1)
  45. Private Const PBM_SETBKCOLOR = CCM_SETBKCOLOR
  46. Private Const WM_USER = &H400
  47. Private Const PBM_SETBARCOLOR = (WM_USER + 9)
  48. Private m_oCPULoad As CPULoad
  49. Private m_lCPUs As Long
  50. Private vbDGr As Long
  51. Private vbLGr As Long
  52. Private vbOWh As Long
  53. Private OldTime As String
  54. Private mBuffer As Long
  55. Private mBufferDC As Long
  56. Private mBlank As Long
  57. Private mBlankDC As Long
  58. Private BufferH As Long
  59. Private BufferW As Long
  60. Private Const PI As Single = 3.14159265358978
  61. Sub ClearBuffer()
  62.     BitBlt mBufferDC, 0, 0, BufferW, BufferH, mBlankDC, 0, 0, vbSrcCopy
  63. End Sub
  64.  
  65. Sub BufferToScreen()
  66.     BitBlt Me.hdc, 140, 110, BufferW, BufferH, mBufferDC, 0, 0, vbSrcCopy
  67. End Sub
  68.  
  69. Sub CreateBlank()
  70.     'create blank
  71.     mBlankDC = CreateCompatibleDC(GetDC(0))
  72.     mBlank = CreateCompatibleBitmap(GetDC(0), BufferW, BufferH)
  73.     SelectObject mBlankDC, mBlank
  74.     SetBkMode mBlankDC, 0
  75. End Sub
  76. Sub CreateBuffer()
  77.     'create buffer (to go to destination hdc)
  78.     mBufferDC = CreateCompatibleDC(GetDC(0))
  79.     mBuffer = CreateCompatibleBitmap(GetDC(0), BufferW, BufferH)
  80.     SelectObject mBufferDC, mBuffer
  81.     SetBkMode mBufferDC, 0
  82. End Sub
  83.  
  84. Private Sub Form_DblClick()
  85.    Unload Me
  86.    End
  87. End Sub
  88.  
  89. Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, _
  90.     y As Single)
  91.     Const WM_NCLBUTTONDOWN = &HA1
  92.     Const HTCAPTION = 2
  93.     If Button = 1 Then
  94.         ReleaseCapture
  95.         SendMessage Me.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
  96.     End If
  97. End Sub
  98. Sub SetTopmostWindow(ByVal hWnd As Long, Optional topmost As Boolean = True)
  99.     Const HWND_NOTOPMOST = -2
  100.     Const HWND_TOPMOST = -1
  101.     Const SWP_NOMOVE = &H2
  102.     Const SWP_NOSIZE = &H1
  103.     SetWindowPos hWnd, IIf(topmost, HWND_TOPMOST, HWND_NOTOPMOST), 0, 0, 0, 0, _
  104.         SWP_NOMOVE + SWP_NOSIZE
  105. End Sub
  106. Sub DrawProgressBar(frmIn As Form, X1 As Long, Y1 As Long, X2 As Long, Y2 As Long, lBgCol As Long, lPbBg As Long, lPbFg As Long, lPerc As Long)
  107. Dim hRPen As Long
  108. Dim y As Long
  109. Dim lPercEndPos As Long
  110. Dim Point As PointAPI
  111.     
  112.     frmIn.ForeColor = lBgCol
  113.     'draw background
  114.     hRPen = CreateSolidBrush(lBgCol)
  115.     SelectObject frmIn.hdc, hRPen
  116.     Rectangle frmIn.hdc, X1, Y1, X2, Y2
  117.     DeleteObject hRPen
  118.     
  119.     'blank out corner pixels
  120.     SetPixel frmIn.hdc, X1, Y1, RGB(255, 0, 255)
  121.     SetPixel frmIn.hdc, X2 - 1, Y1, RGB(255, 0, 255)
  122.     SetPixel frmIn.hdc, X1, Y2 - 1, RGB(255, 0, 255)
  123.     SetPixel frmIn.hdc, X2 - 1, Y2 - 1, RGB(255, 0, 255)
  124.     
  125.     If lPerc = 100 Then
  126.         frmIn.ForeColor = &H6050FF
  127.     Else
  128.         frmIn.ForeColor = lPbBg
  129.     End If
  130.     For y = Y1 + 2 To Y2 - 3 Step 2
  131.         Point.x = X1 + 2: Point.y = y
  132.         MoveToEx frmIn.hdc, X1 + 2, y, Point
  133.         LineTo frmIn.hdc, X2 - 2, y
  134.     Next
  135.     
  136.     If lPerc = 0 Or lPerc = 100 Then GoTo LastBit
  137.     
  138.     lPercEndPos = (((X2 - X1 - 4) / 100) * lPerc) + X1 + 2
  139.     
  140.     If lPerc > 95 Then
  141.         frmIn.ForeColor = &H6050FF
  142.     ElseIf lPerc > 85 Then
  143.         frmIn.ForeColor = &HC0FFFF
  144.     Else
  145.         frmIn.ForeColor = lPbFg
  146.     End If
  147.     
  148.     For y = Y1 + 2 To Y2 - 3 Step 2
  149.         Point.x = X1 + 2: Point.y = y
  150.         MoveToEx frmIn.hdc, X1 + 2, y, Point
  151.         LineTo frmIn.hdc, lPercEndPos, y
  152.     Next
  153. LastBit:
  154.     Me.Refresh
  155.     DoEvents
  156. End Sub
  157. Sub FrmTextOut(FormIn As Form, sIn As String, xPos As Integer, ypos As Integer, lColor As Long)
  158.     SetTextColor FormIn.hdc, vbBlack
  159.     TextOut FormIn.hdc, xPos, ypos + 1, sIn, Len(sIn)
  160.     TextOut FormIn.hdc, xPos, ypos - 1, sIn, Len(sIn)
  161.     TextOut FormIn.hdc, xPos - 1, ypos, sIn, Len(sIn)
  162.     TextOut FormIn.hdc, xPos + 1, ypos, sIn, Len(sIn)
  163.     
  164.     SetTextColor FormIn.hdc, lColor
  165.     TextOut FormIn.hdc, xPos, ypos, sIn, Len(sIn)
  166.  
  167. End Sub
  168. Private Sub Form_Load()
  169. Dim x As Long, y As Long
  170.    
  171.    App.Title = "Fosters Desktop Info"
  172.  
  173.     If Len(GetSetting(App.Title, "Settings", "Posx")) > 0 Then
  174.         x = CLng(GetSetting(App.Title, "Settings", "Posx"))
  175.     Else
  176.         x = Screen.Width - (Me.Width * 1.2)
  177.     End If
  178.     If Len(GetSetting(App.Title, "Settings", "Posy")) > 0 Then
  179.         y = CLng(GetSetting(App.Title, "Settings", "Posy"))
  180.     Else
  181.         y = (Me.Width * 0.5)
  182.     End If
  183.     If x < 0 Or x > Screen.Width Then x = Screen.Width - (Me.Width * 1.2)
  184.     If y < 0 Or y > Screen.Height Then y = (Me.Width * 0.5)
  185.     Me.Top = y
  186.     Me.Left = x
  187.  
  188.    'for a dot shade background
  189.    'For Y = 1 To Me.ScaleHeight Step 2
  190.    '   For X = 1 To Me.ScaleWidth Step 2
  191.    '      SetPixel Me.hdc, X, Y, 0
  192.    '   Next
  193.    'Next
  194.  
  195.    vbLGr = RGB(100, 200, 130)
  196.    vbDGr = RGB(30, 60, 30)
  197.    vbOWh = RGB(220, 220, 220)
  198.    
  199.    InitCPU
  200.    
  201.    FrmTextOut Me, "Physical RAM", 5, 5, vbOWh
  202.    FrmTextOut Me, "Virtual RAM", 5, 25, vbOWh
  203.    FrmTextOut Me, "CPU", 5, 45, vbOWh
  204.    FrmTextOut Me, "Host IP", 5, 70, vbOWh
  205.    FrmTextOut Me, "Host Name", 5, 85, vbOWh
  206.    
  207.    FrmTextOut Me, GetIPAddress, 100, 70, vbOWh
  208.    FrmTextOut Me, GetIPHostName, 100, 85, vbOWh
  209.    
  210.    Timer1_Timer
  211.  
  212.    
  213.    'SetTopmostWindow Me.hWnd
  214.  
  215.    BufferW = 60:    BufferH = BufferW
  216.    
  217.    CreateBlank
  218.    DrawBlank
  219.    CreateBuffer
  220.    
  221.    ShowTime
  222.    
  223.    DrawCalendar
  224.    
  225.    Me.Refresh
  226.    SetColorTransparent Me, RGB(255, 0, 255)
  227.    Timer1.Enabled = True
  228. End Sub
  229. Sub DrawCalendar()
  230. Dim Stamp As New clsCalendarStamp
  231. With Stamp
  232.     .Background = vbBlack
  233.     .BackgroundTrimIT = border
  234.     
  235.     .TrimITDepth = 1
  236.     
  237.     .Left = 15
  238.     .Top = 180
  239.     
  240.     .CalendarMonth = Month(Now)
  241.     .CalendarYear = Year(Now)
  242.     
  243.     .TargetImage = Me
  244.     
  245.     .DayBold = True
  246.     .DayColor = RGB(230, 230, 230)
  247.     .DayFont = "MS Sans Serif"
  248.     .DayFontSize = 8
  249.     
  250.     .LabelBold = True
  251.     .LabelColor = RGB(255, 255, 220)
  252.     .LabelFont = "MS Sans Serif"
  253.     .LabelFontSize = 8
  254.     
  255.     .TitleBold = True
  256.     .TitleColor = RGB(230, 230, 255)
  257.     .TitleFont = "MS Sans Serif"
  258.     .TitleFontSize = 10
  259.     
  260.     .TodayColor = RGB(255, 130, 155)
  261.     
  262.     .DrawCalendar
  263. End With
  264.  
  265. End Sub
  266. Function GetMEMORY() As Long()
  267. Dim memsts As MEMORYSTATUS
  268. Dim RetMem(2) As Long
  269.  
  270.  
  271.     GlobalMemoryStatus memsts
  272.     RetMem(0) = Int((100 / memsts.dwTotalPhys) * (memsts.dwTotalPhys - memsts.dwAvailPhys))
  273.     RetMem(1) = Int((100 / memsts.dwTotalVirtual) * (memsts.dwTotalVirtual - memsts.dwAvailVirtual))
  274.  
  275.     GetMEMORY = RetMem
  276. End Function
  277.  
  278.  
  279.  
  280. Private Sub InitCPU()
  281. Dim i As Long
  282. Const lOffset As Long = 30
  283.     
  284.     Set m_oCPULoad = New CPULoad
  285.     m_lCPUs = m_oCPULoad.GetCPUCount
  286.         
  287. End Sub
  288.  
  289. Private Function ReturnCPUPercent(lCPU As Long) As Single
  290.     m_oCPULoad.CollectCPUData
  291.     ReturnCPUPercent = m_oCPULoad.GetCPUUsage(lCPU)
  292. End Function
  293.  
  294. Private Sub Form_Unload(Cancel As Integer)
  295.     SaveSetting App.Title, "Settings", "Posx", Me.Left
  296.     SaveSetting App.Title, "Settings", "Posy", Me.Top
  297.     
  298.     Set m_oCPULoad = Nothing
  299.     DeleteObject mBlank: DeleteObject mBlankDC
  300.     DeleteObject mBuffer: DeleteObject mBufferDC
  301. End Sub
  302.  
  303.  
  304.  
  305. Private Sub Timer1_Timer()
  306. Dim rMEM() As Long
  307. Dim lL As Long
  308. Dim lR As Long
  309.    lL = 100: lR = 200
  310.    
  311.    rMEM = GetMEMORY
  312.    DrawProgressBar Me, lL, 5, lR, 18, 0, vbDGr, vbLGr, rMEM(0)
  313.    DrawProgressBar Me, lL, 25, lR, 38, 0, vbDGr, vbLGr, rMEM(1)
  314.    DrawProgressBar Me, lL, 45, lR, 58, 0, vbDGr, vbLGr, ReturnCPUPercent(1)
  315.    
  316.    'FrmTextOut Me, Format(Now, "Mmmm dd YYYY"), 5, 110, vbOWh
  317.    
  318.    ShowTime
  319.    
  320. End Sub
  321. Sub ShowTime()
  322.    ClearBuffer
  323.    ClockToBuffer
  324.    BufferToScreen
  325. End Sub
  326. Sub DrawBlank()
  327. Dim m_line As New LineGS
  328. Dim m_Grad As New clsGradient
  329. Dim BM As BITMAP
  330.  
  331. Dim mDl As Long
  332. Dim An As Single
  333.    With m_Grad
  334.        .Angle = 130
  335.        .Color2 = vbWhite 'RGB(150, 200, 255)
  336.        .Color1 = RGB(180, 200, 255)
  337.        .PictureHDC = mBlankDC
  338.        .PictureHWND = GetObject(mBlank, Len(BM), BM)
  339.        .Draw BufferW, BufferH
  340.    End With
  341.    
  342.    mDl = (BufferW \ 2) - 1
  343.    
  344.    For An = 0 To 359 Step 30
  345.        SetPixel mBlankDC, mDl + GimmeX(An, mDl * 0.8), mDl + GimmeY(An, mDl * 0.8), 0
  346.    Next
  347.    With m_line
  348.       .LineGP mBlankDC, 0, BufferH - 1, BufferW, BufferH - 1, 0
  349.       .LineGP mBlankDC, BufferW - 1, 0, BufferW - 1, BufferH, 0
  350.    End With
  351. End Sub
  352. Sub ClockToBuffer()
  353. Dim m_line As New LineGS
  354. Dim hh As Long
  355. Dim mm As Long
  356. Dim ss As Long
  357. Dim mDl As Long
  358. Dim ssAng As Single
  359.    hh = Format(Now, "hh"): If hh >= 12 Then hh = hh - 12
  360.    mm = Format(Now, "nn")
  361.    ss = Format(Now, "ss")
  362.    ssAng = 180 - (CSng(ss * 6))
  363.    mDl = (BufferW \ 2) - 1
  364.    With m_line
  365.        .LineGP mBufferDC, mDl, mDl, mDl + GimmeX(ssAng, mDl * 0.9), _
  366.                                     mDl + GimmeY(ssAng, mDl * 0.9), RGB(100, 100, 100)
  367.        .LineGP mBufferDC, mDl, mDl, mDl + GimmeX(180 - (CSng(((hh * 60) + mm) * 0.5)), mDl * 0.6), _
  368.                                     mDl + GimmeY(180 - (CSng(((hh * 60) + mm) * 0.5)), mDl * 0.6), 0
  369.        .LineGP mBufferDC, mDl, mDl, mDl + GimmeX(180 - CSng(mm * 6), mDl * 0.9), mDl + GimmeY(180 - CSng(mm * 6), mDl * 0.9), 0
  370.        .CircleGP mBufferDC, mDl, mDl, 4, 4, 0
  371.        .CircleGP mBufferDC, mDl, mDl, 2, 2, 0
  372.    End With
  373. End Sub
  374. Function GimmeX(ByVal aIn As Single, lIn As Long) As Long
  375.     GimmeX = sIn(aIn * (PI / 180)) * lIn
  376. End Function
  377. Function GimmeY(ByVal aIn As Single, lIn As Long) As Long
  378.     GimmeY = Cos(aIn * (PI / 180)) * lIn
  379. End Function
  380.  
  381.  
  382.