home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 6_2008-2009.ISO / data / zips / A_3D_Pie_D2143942152009.psc / 3DPieDriveInformation / frmDriveSpacesProX.frm < prev    next >
Text File  |  2009-02-13  |  17KB  |  414 lines
  1. VERSION 5.00
  2. Begin VB.Form FormDrivesInformation 
  3.    AutoRedraw      =   -1  'True
  4.    Caption         =   "3D Pie - Drives Information"
  5.    ClientHeight    =   975
  6.    ClientLeft      =   60
  7.    ClientTop       =   450
  8.    ClientWidth     =   4935
  9.    FillColor       =   &H0000C0C0&
  10.    FillStyle       =   0  'Solid
  11.    Icon            =   "frmDriveSpacesProX.frx":0000
  12.    LinkTopic       =   "Form1"
  13.    MaxButton       =   0   'False
  14.    ScaleHeight     =   65
  15.    ScaleMode       =   3  'Pixel
  16.    ScaleWidth      =   329
  17.    StartUpPosition =   2  'CenterScreen
  18. End
  19. Attribute VB_Name = "FormDrivesInformation"
  20. Attribute VB_GlobalNameSpace = False
  21. Attribute VB_Creatable = False
  22. Attribute VB_PredeclaredId = True
  23. Attribute VB_Exposed = False
  24. Option Explicit
  25. '********************************
  26. '*  3D Pie Drives Information  *
  27. '********************************
  28. '*   Created by GioRock 2009    *
  29. '*     giorock@libero.it        *
  30. '********************************
  31.  
  32. Private Type ImgPie
  33.     hDCFree As Long
  34.     hBmpFree As Long
  35.     hOldFreeObj As Long
  36.     hDCUsed As Long
  37.     hBmpUsed As Long
  38.     hOldUsedObj As Long
  39.     hDCNoDrive As Long
  40.     hBmpNoDrive As Long
  41.     hOldNoDriveObj As Long
  42.     Width As Long
  43.     Height As Long
  44.     BorderHeight As Single
  45. End Type
  46.  
  47. Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
  48. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
  49. Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
  50. Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
  51. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  52.  
  53. Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
  54.  
  55. Private Const pi As Double = 3.14159265358979
  56. Private Const hpi As Double = (pi / 2)
  57. Private Const Convert As Double = (pi / 180)
  58.  
  59. Private DA As classDriveAnalyzer
  60.  
  61. Private IC As ImgPie
  62.  
  63. Private token As Long ' Needed to close GDI+
  64.  
  65. Private Sub DrawUsage(Percent As Single, ByVal OffsetX As Long, ByVal OffsetY As Long)
  66. Dim graphics As Long, pen As Long, img As Long
  67. Dim path As Long, polyPoints() As POINTL
  68. Dim region As Long, degree As Double
  69. Dim X As Single, Y As Single
  70.     
  71.     If Percent < 0 Then: Percent = 0
  72.     If Percent > 100 Then: Percent = 100
  73.     
  74.     ' Correct offset in drawing region
  75.     Percent = Percent + 1
  76.     
  77.     ' Draw a free Disk
  78.     BitBlt hDC, OffsetX, OffsetY, IC.Width, IC.Height, IC.hDCFree, 0, 0, vbSrcCopy
  79.      
  80.     ' Initialization
  81.     Call GdipCreateFromHDC(Me.hDC, graphics) ' Initialize the graphics class - required for all drawing
  82.     
  83.     ' Uses maximum quality
  84.     GdipSetCompositingQuality graphics, CompositingQualityHighQuality
  85.     GdipSetSmoothingMode graphics, SmoothingModeAntiAlias
  86.     
  87.     ' Get the image hBmp handle
  88.     Call GdipCreateBitmapFromHBITMAP(IC.hBmpUsed, 0, img)
  89.     
  90.     ' Create a path that consists of a single polygon
  91.     ' Set the polygon points - Start and End at center of ellipse
  92.     ' First and Last are the same
  93.     ReDim Preserve polyPoints(0) As POINTL
  94.     polyPoints(0).X = OffsetX + (IC.Width / 2)
  95.     polyPoints(0).Y = OffsetY + (IC.Height / 2) - IC.BorderHeight
  96.     
  97.     ' 45░ default
  98.     ReDim Preserve polyPoints(UBound(polyPoints) + 1) As POINTL
  99.     For degree = (360 / 100) + 45 To ((360 / 100) * Percent) + 45 Step hpi
  100.         DegreesToXY OffsetX + (IC.Width / 2), OffsetY + (IC.Height / 2), degree, (IC.Width / 2) + IC.BorderHeight, (IC.Height / 2) + IC.BorderHeight, X, Y
  101.         polyPoints(UBound(polyPoints)).X = X
  102.         polyPoints(UBound(polyPoints)).Y = Y
  103.         ReDim Preserve polyPoints(UBound(polyPoints) + 1) As POINTL
  104.     Next degree
  105.     
  106.     degree = degree - hpi
  107.     ' Draw vertical line only if visible
  108.     If degree > 102 And degree < 258 Then
  109.         SetVerticalLineByDegrees degree, polyPoints(), OffsetX, OffsetY
  110.     End If
  111.     
  112.     ' Ensure to close the polygon
  113.     polyPoints(UBound(polyPoints)).X = OffsetX + (IC.Width / 2)
  114.     polyPoints(UBound(polyPoints)).Y = OffsetY + (IC.Height / 2)
  115.     
  116.  
  117.     ' Create the path object and add the polygon to it
  118.     Call GdipCreatePath(FillModeAlternate, path)
  119.     Call GdipAddPathPolygonI(path, polyPoints(0), UBound(polyPoints))
  120.     
  121.     ' Now create a region object based on the path
  122.     ' The region object will allow us to set the clipping area/region
  123.     Call GdipCreateRegionPath(path, region)
  124.     
  125.     ' Set the clipping region
  126.     ' The default combine mode is CombineModeIntersect
  127.     Call GdipSetClipRegion(graphics, region, CombineModeIntersect)
  128.     
  129.     
  130.     ' Create a pen to draw the clipping region outline
  131.     ' NOTE: The border looks a bit odd with 1 pixel width
  132. '    Call GdipCreatePen1(Red, 1, UnitPixel, pen)
  133. '    ' Draw the outline based on the path
  134. '    ' NOTE: You could also use GdipDrawPolygon if you wanted
  135. '    Call GdipDrawPath(graphics, pen, path)
  136.     
  137.     ' This will draw the image with auto-scaling, but since we won't be able to
  138.     '  see the entire image, it won't matter here. The extra size will ensure that
  139.     '  the entire clipping area will be visible.
  140.     Call GdipDrawImageI(graphics, img, OffsetX, OffsetY)
  141.     
  142.     ' Cleanup
  143.     Erase polyPoints
  144.     Call GdipDisposeImage(img)
  145. '    Call GdipDeletePen(pen)
  146.     Call GdipDeletePath(path)
  147.     Call GdipDeleteRegion(region)
  148.     Call GdipDeleteGraphics(graphics)
  149.     
  150.     Percent = Percent - 1
  151.     
  152. End Sub
  153.  
  154.  
  155.  
  156. Private Function Print3DAntiAliasTextAndReturnWidth(ByVal StrText As String, ByVal OffsetX As Long, ByVal OffsetY As Long, ByVal TextColor As Colors, ByVal FirstColor As Colors, ByVal SecondColor As Colors, Optional sFontName As String = "Courier New", Optional FontSize As Single = 12, Optional FontStyle As FontStyle = FontStyleBoldItalic) As Single
  157. Dim graphics As Long, brush As Long
  158. Dim fontFam As Long, curFont As Long
  159. Dim rcLayout As RECTF   ' Designates the string drawing bounds
  160.     
  161.     ' Initializations
  162.     Call GdipCreateFromHDC(Me.hDC, graphics) ' Initialize the graphics class - required for all drawing
  163.     
  164.     GdipSetCompositingQuality graphics, CompositingQualityHighQuality
  165.     GdipSetSmoothingMode graphics, SmoothingModeAntiAlias
  166.     
  167.     ' Create a font family object to allow use to create a font
  168.     ' We have no font collection here, so pass a NULL for that parameter
  169.     Call GdipCreateFontFamilyFromName(StrConv(sFontName, vbUnicode), 0, fontFam)
  170.     ' Create the font from the specified font family name
  171.     Call GdipCreateFont(fontFam, FontSize, FontStyle, UnitPixel, curFont)
  172.     
  173.     rcLayout.Left = (OffsetX * 2) + IC.Width + 1
  174.     rcLayout.Top = OffsetY + 2
  175.     ' Create a brush to draw the text with
  176.     Call GdipCreateSolidFill(SecondColor, brush)
  177.     
  178.     ' Now we'll use anti-aliasing
  179.     Call GdipSetTextRenderingHint(graphics, TextRenderingHintAntiAlias)
  180.     ' We have no string format object, so pass a NULL for that parameter
  181.     Call GdipDrawString(graphics, StrConv(StrText, vbUnicode), Len(StrText), curFont, rcLayout, 0, brush)
  182.     
  183.     Call GdipDeleteBrush(brush)
  184.     brush = 0 ' remember to reset before calling
  185.     
  186.     ' Set up another drawing area
  187.     rcLayout.Left = (OffsetX * 2) + IC.Width - 1
  188.     rcLayout.Top = OffsetY
  189.     Call GdipCreateSolidFill(FirstColor, brush)
  190.     ' Now we'll use anti-aliasing
  191.     Call GdipSetTextRenderingHint(graphics, TextRenderingHintAntiAlias)
  192.     ' We have no string format object, so pass a NULL for that parameter
  193.     Call GdipDrawString(graphics, StrConv(StrText, vbUnicode), Len(StrText), curFont, rcLayout, 0, brush)
  194.     
  195.     ' Set up another drawing area
  196.     rcLayout.Left = (OffsetX * 2) + IC.Width
  197.     rcLayout.Top = OffsetY + 1
  198.     Call GdipDeleteBrush(brush)
  199.     brush = 0 ' remember to reset before calling
  200.     Call GdipCreateSolidFill(TextColor, brush)
  201.     ' Now we'll use anti-aliasing
  202.     Call GdipSetTextRenderingHint(graphics, TextRenderingHintAntiAlias)
  203.     ' We have no string format object, so pass a NULL for that parameter
  204.     Call GdipDrawString(graphics, StrConv(StrText, vbUnicode), Len(StrText), curFont, rcLayout, 0, brush)
  205.     
  206.     ' Get TextWidth by GDI+
  207.     Dim rcf As RECTF
  208.     Dim cpf As Long, lf As Long
  209.     GdipMeasureString graphics, StrConv(StrText, vbUnicode), Len(StrText), curFont, rcLayout, 0, rcf, cpf, lf
  210. '    Debug.Print rc.Left, rc.Top, rc.Right, rc.Bottom, cpf, lf
  211.     Print3DAntiAliasTextAndReturnWidth = rcf.Right
  212.     
  213.     ' Cleanup
  214.     Call GdipDeleteFont(curFont)     ' Delete the font object
  215.     Call GdipDeleteFontFamily(fontFam)  ' Delete the font family object
  216.     Call GdipDeleteBrush(brush)
  217.     Call GdipDeleteGraphics(graphics)
  218.     
  219. End Function
  220.  
  221.  
  222. Private Sub DegreesToXY(ByVal CenterX As Single, ByVal CenterY As Single, ByVal degree As Double, ByVal RadiusX As Single, ByVal RadiusY As Single, X As Single, Y As Single)
  223.     X = (CenterX - (Sin(-degree * Convert) * RadiusX))
  224.     Y = (CenterY - (Sin((90 + degree) * Convert) * RadiusY))
  225. End Sub
  226. Private Sub Form_Load()
  227. Dim GpInput As GdiplusStartupInput
  228.    
  229.    GpInput.GdiplusVersion = 1
  230.    If GdiplusStartup(token, GpInput) <> Ok Then
  231.       MsgBox "Error loading GDI+!", vbCritical
  232.       Unload Me
  233.       Exit Sub
  234.    End If
  235.     
  236. '    pi = Atn(1) * 4
  237. '    hpi = pi / 2
  238. '    Convert = (pi / 180)
  239.  
  240.     ' +1 about offset for antialias pixelings
  241.     ' 100x50 real images dimension
  242.     CreateMemImages 101, 56
  243.     Draw3DGradientDisk IC.hDCFree, GhostWhite, LimeGreen, Silver, Green
  244.     Draw3DGradientDisk IC.hDCUsed, WhiteSmoke, Tomato, Tan, Red
  245.     Draw3DGradientDisk IC.hDCNoDrive, Snow, DarkGray, LightGray, Gray
  246.     
  247. '    DrawUsage 28, 5, 5
  248. '    Me.Width = (Print3DAntiAliasTextAndReturnWidth("C:\ [GIOROCK] on Drive Fixed" + vbCrLf + _
  249. '                                       "FAT TYPE: NTFS" + vbCrLf + _
  250. '                                       "T: 320GB - F: 172GB - U: 128GB" + vbCrLf + _
  251. '                                       "T: 100%  - F:  60%  - U:  40%", _
  252. '                                       5, 5, SteelBlue, Wheat, White) + IC.Width + 12 + 8) * Screen.TwipsPerPixelX
  253.     
  254. '    BitBlt hDC, 5, 5, IC.Width, IC.Height, IC.hDCFree, 0, 0, vbSrcCopy
  255. '    BitBlt hDC, 5, 5, IC.Width, IC.Height, IC.hDCUsed, 0, 0, vbSrcCopy
  256. '    BitBlt hDC, 5, 5, IC.Width, IC.Height, IC.hDCNoDrive, 0, 0, vbSrcCopy
  257.     
  258.     Set DA = New classDriveAnalyzer
  259.     
  260.     GetDataDrives
  261.     
  262. End Sub
  263.  
  264.  
  265.  
  266. Private Sub Form_Unload(Cancel As Integer)
  267.     With IC
  268.         .hOldFreeObj = SelectObject(.hDCFree, .hOldFreeObj)
  269.         DeleteObject .hBmpFree
  270.         DeleteDC .hDCFree
  271.         .hOldUsedObj = SelectObject(.hDCUsed, .hOldUsedObj)
  272.         DeleteObject .hBmpUsed
  273.         DeleteDC .hDCUsed
  274.         .hOldNoDriveObj = SelectObject(.hDCNoDrive, .hOldNoDriveObj)
  275.         DeleteObject .hBmpNoDrive
  276.         DeleteDC .hDCNoDrive
  277.     End With
  278.     ' Unload the GDI+ dll
  279.     Call GdiplusShutdown(token)
  280.     Set DA = Nothing
  281.     End
  282.     Set FormDrivesInformation = Nothing
  283. End Sub
  284.  
  285.  
  286.  
  287. Private Sub CreateMemImages(ByVal Width As Long, Height As Long, Optional BorderHeight As Single = 5)
  288.  
  289.     With IC
  290.         .hDCFree = CreateCompatibleDC(0)
  291.         .hBmpFree = CreateCompatibleBitmap(hDC, Width, Height)
  292.         .hOldFreeObj = SelectObject(.hDCFree, .hBmpFree)
  293.         BitBlt .hDCFree, 0, 0, Width, Height, hDC, 0, 0, vbSrcCopy
  294.         .hDCUsed = CreateCompatibleDC(0)
  295.         .hBmpUsed = CreateCompatibleBitmap(hDC, Width, Height)
  296.         .hOldUsedObj = SelectObject(.hDCUsed, .hBmpUsed)
  297.         BitBlt .hDCUsed, 0, 0, Width, Height, hDC, 0, 0, vbSrcCopy
  298.         .hDCNoDrive = CreateCompatibleDC(0)
  299.         .hBmpNoDrive = CreateCompatibleBitmap(hDC, Width, Height)
  300.         .hOldNoDriveObj = SelectObject(.hDCNoDrive, .hBmpNoDrive)
  301.         BitBlt .hDCNoDrive, 0, 0, Width, Height, hDC, 0, 0, vbSrcCopy
  302.         .Width = Width
  303.         .Height = Height
  304.         .BorderHeight = BorderHeight
  305.     End With
  306.     
  307. End Sub
  308.  
  309. Private Sub GetDataDrives()
  310. Dim i As Integer, k As Integer
  311. Dim sDrive() As String
  312. Dim sVoume As String
  313. Dim sFileSystem As String
  314. Dim sSerialNumber As String
  315. Dim sText As String
  316. Dim TotalSpace As Currency
  317. Dim FreeSpace As Currency
  318. Dim UsedSpace As Currency
  319. Dim UsedPercent As Single
  320. Dim maxTextWidth As Single
  321. Dim maxTempTextWidth As Single
  322.  
  323.     With DA
  324.         .GetDrives sDrive
  325.         For i = 0 To UBound(sDrive())
  326.             If .Exists(sDrive(i)) Then
  327.                 .GetDriveInfo sDrive(i), sVoume, sFileSystem, sSerialNumber
  328.                 .GetDriveSpace sDrive(i), TotalSpace, FreeSpace, UsedSpace, UsedPercent
  329.                 DrawUsage UsedPercent, 5, k + 5
  330.                 sText = sDrive(i) + " - [" + sVoume + "] on " + .GetDriveTypeName(sDrive(i)) + vbCrLf
  331.                 sText = sText + "FS: " + sFileSystem + " - SN: " + sSerialNumber + vbCrLf
  332.                 sText = sText + "T: " + .ParseSize(TotalSpace) + " - F: " + .ParseSize(FreeSpace) + " - U: " + .ParseSize(UsedSpace) + vbCrLf
  333.                 sText = sText + "Usage: " + CStr(UsedPercent) + "%"
  334.                 maxTempTextWidth = Print3DAntiAliasTextAndReturnWidth(sText, 5, k + 5, IndianRed, Wheat, White)
  335.                 If maxTempTextWidth > maxTextWidth Then: maxTextWidth = maxTempTextWidth
  336.             Else
  337.                 BitBlt hDC, 5, k + 5, IC.Width, IC.Height, IC.hDCNoDrive, 0, 0, vbSrcCopy
  338.                 sText = sDrive(i) + " - No Disk present on " + .GetDriveTypeName(sDrive(i))
  339.                 maxTempTextWidth = Print3DAntiAliasTextAndReturnWidth(sText, 5, k + (IC.Height / 2) - 5, BackColor, Wheat, White)
  340.                 If maxTempTextWidth > maxTextWidth Then: maxTextWidth = maxTempTextWidth
  341.             End If
  342.             k = k + 65
  343.         Next i
  344.         Me.Width = (IC.Width + maxTextWidth + 14 + 8) * Screen.TwipsPerPixelX
  345.         Me.Height = (k + 35) * Screen.TwipsPerPixelY
  346.     End With
  347.  
  348.     Erase sDrive
  349.     
  350.     Refresh
  351.  
  352. End Sub
  353.  
  354. Private Sub Draw3DGradientDisk(ByVal hDC As Long, ByVal FirstSurfaceColor As Colors, ByVal SecondSurfaceColor As Colors, ByVal FirstBorderColor As Colors, ByVal SecondBorderColor As Colors)
  355. Dim graphics As Long, brush As Long, pen As Long
  356. Dim pt1 As POINTL, pt2 As POINTL
  357.  
  358.     ' Set the gradient color points
  359.     pt1.Y = IC.BorderHeight
  360.     pt2.X = 100
  361.     pt2.Y = 50 + IC.BorderHeight
  362.     
  363.     ' Initializations
  364.     Call GdipCreateFromHDC(hDC, graphics) ' Initialize the graphics class - required for all drawing
  365.     
  366.     ' Uses maximum quality
  367.     GdipSetCompositingQuality graphics, CompositingQualityHighQuality
  368.     GdipSetSmoothingMode graphics, SmoothingModeAntiAlias
  369.     
  370.     ' Create the gradient brush; we'll use tiling
  371.     Call GdipCreateLineBrushI(pt1, pt2, FirstBorderColor, SecondBorderColor, WrapModeTileFlipXY, brush)
  372.     
  373.     ' Fill Ellipse with gradient brush
  374.     Call GdipFillEllipseI(graphics, brush, 0, IC.BorderHeight, 100, 50)
  375.     Call GdipDeleteBrush(brush)
  376.     
  377.     pt1.Y = 0
  378.     pt2.X = 100
  379.     pt2.Y = 50
  380.     
  381.     brush = 0 ' remember to reset before calling
  382.     ' Create another gradient brush
  383.     Call GdipCreateLineBrushI(pt1, pt2, FirstSurfaceColor, SecondSurfaceColor, WrapModeTileFlipXY, brush)
  384.     ' Fill another Ellipse with gradient brush
  385.     Call GdipFillEllipseI(graphics, brush, 0, 0, 100, 50)
  386.     
  387.     'Cleanup
  388.     Call GdipDeleteBrush(brush)
  389.     Call GdipDeleteGraphics(graphics)
  390.     
  391. End Sub
  392.  
  393. Private Sub SetVerticalLineByDegrees(lastDegree As Double, pl() As POINTL, ByVal OffsetX As Long, ByVal OffsetY As Long)
  394. Dim X As Single, Y As Single, newOffSetX As Single
  395. Dim iRedim As Integer
  396.  
  397.     ' Try to redim array to draw vertical line in border disk
  398.     ' when possible
  399.     DegreesToXY OffsetX + (IC.Width / 2), OffsetY + (IC.Height / 2), lastDegree, (IC.Width / 2), (IC.Height / 2), X, Y
  400.     ' how many arrays to delete???
  401.     iRedim = Fix(Abs(X - pl(UBound(pl) - 1).X) / hpi) + 1
  402.     
  403.     ' redim array to new value
  404.     ReDim Preserve pl(UBound(pl) - iRedim)
  405.     
  406.     ' calculate new offset X and set Y on border to surface disk
  407.     newOffSetX = Abs(X - pl(UBound(pl) - 1).X) + 1
  408.     pl(UBound(pl)).X = X + IIf(lastDegree > 180, -newOffSetX, newOffSetX)
  409.     pl(UBound(pl)).Y = Y - IC.BorderHeight
  410.     
  411.     ReDim Preserve pl(UBound(pl) + 1)
  412.  
  413. End Sub
  414.