|
|
Please support our sponsor:
API, Graphics and Miscellaneous
Use API to get all info on local hard drives and network drives.
How to call Help file functions using API.
See if Crystal Reports is being viewed on screen or is done printing.
Function to find the number of working days there are between two dates.
Function to add simple encryption to a string.
Function to round a value up,down,or near to another value.
How to remove Control Box menu items.
How to get information on the printer type, driver and port.
How to move a control on a form at runtime.
How to call a command button on another form.
How to program a delay using the Timer function.
How to create hot key labels.
Got a useful snippet you'd like to share? Submit it here.
'--------------------------------------------------------------------
'Author: Dr. John A. Nyhart
'work : john_nyhart@medicalogic.com
'home : jnyhart@spessart.com
'web : www.spessart.com/users/jnyhart/john1.htm
'Posted: 07/18/97
'
'This sub will get all the information on your local hard drive as well
'as all the network drives that you are connected to. I hope this helps
'you and others.
'--------------------------------------------------------------------
1. Place the following code into a module.
Declare Function GetVolumeInformation Lib "kernel32" _
Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, _
ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, _
lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, _
lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, _
ByVal nFileSystemNameSize As Long) As Long
Declare Function GetLogicalDrives& Lib "kernel32" ()
Declare Function GetDriveType& Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String)
Declare Function GetDiskFreeSpace& Lib "kernel32" _
Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, _
lpSectorsPerCluster As Long, lpBytesPerSector As Long, _
lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters As Long)
Public vararyDriveInfo(26, 11) ' a Variant Array to hold the info
' ************************************************************************************
2. This is a sub that can be called from a form loading or from a command button.
Sub getDriveInfo()
' *****************************************
' SUB: This sub will get all the drive
' info for all the hard drives and
' network drives.
' 2/19/95
'
' There is a array named vararyDriveInfo that
' holds all the info for up to 26 drives (A-Z).
'
' Array Format:
' x,1 = Is there a drive for this letter
' x,2 = Drive Letter
' x,3 = Drive Type 2=Floppy, 3=Disk Fixed (local) 4=Disk Remote (Network)
' x,4 = Sectors
' x,5 = Bytes / Sector
' x,6 = Number of free sectors
' x,7 = Total Clusters
' x,8 = Total Bytes
' x,9 = Free Bytes
' x,10 = Percent of Free Bytes
' x,11 = Vol Name
'
' *********************************************************************
Dim ournum As Long
Dim rv As Long
Dim DriveType As Long
Dim c As Long
Dim d As Long
Dim e As Long
Dim f As Long
Dim h As Long
Dim Counter As Integer
Dim CompareTo
Dim tmpDrvLet As String
Dim SectorsPerCluster&, BytesPerSector&, NumberOfFreeClustors&, TotalNumberOfClustors&
Dim BytesFreeas, BytesTotal, FreeBytes, TotalBytes As Variant
Dim dl&, lpVolumeSerialNumber&, lpMaximumComponentLength&, lpFileSystemFlags&
Dim lpVolumeNameBuffer As String
Dim rc
Dim A As String
Dim b As String
Dim g As String
Dim s$, sz&
' *** get the logical Drives
rv = 0
rv = GetLogicalDrives&()
If rv = 0 Then
MsgBoxText = "No Logical Drives Found. Program will stop."
MsgBoxButton = MB_OK + MB_ICONSTOP
MsgBoxTitle = "Error"
MsgBox MsgBoxText, MsgBoxButton, MsgBoxTitle
Stop
Exit Sub
End If
' *** clear the VarArray
Erase vararyDriveInfo
' *** set the var
b = String$(255, 0)
c = 200
g = String$(255, 0)
h = 100
For Counter = 1 To 26
CompareTo = (2 ^ (Counter - 1))
If (rv And CompareTo) <> 0 Then
vararyDriveInfo(Counter, 1) = True ' Found a drive
tmpDrvLet = Chr(Counter + 64) ' Build a drive letter
vararyDriveInfo(Counter, 2) = tmpDrvLet ' Save the drive letter
tmpDrvLet = tmpDrvLet & ":\" ' Add the root stuff
DriveType = GetDriveType&(tmpDrvLet) ' Get the drive type
vararyDriveInfo(Counter, 3) = DriveType ' Save the drive type
If DriveType = 3 Or DriveType = 4 Then ' local or network drives only
' *** get the vol name
A = tmpDrvLet 'DriveLtr & "\:"
rc = GetVolumeInformation(A, b, c, d, e, f, g, h)
vararyDriveInfo(Counter, 11) = b
' *** let's get the Drive info for this HardDrive
dl& = GetDiskFreeSpace(tmpDrvLet, SectorsPerCluster, BytesPerSector, _
NumberOfFreeClustors, TotalNumberOfClustors)
vararyDriveInfo(Counter, 4) = Format(SectorsPerCluster, "#,0")
vararyDriveInfo(Counter, 5) = Format(BytesPerSector, "#,0")
vararyDriveInfo(Counter, 6) = Format(NumberOfFreeClustors, "#,0")
vararyDriveInfo(Counter, 7) = Format(TotalNumberOfClustors, "#,0")
TotalBytes = (TotalNumberOfClustors / 100) * (SectorsPerCluster / 100) * (BytesPerSector / 100)
vararyDriveInfo(Counter, 8) = Format(TotalBytes, "#,0")
FreeBytes = (NumberOfFreeClustors / 100) * (SectorsPerCluster / 100) * (BytesPerSector / 100)
vararyDriveInfo(Counter, 9) = Format(FreeBytes, "#,0")
vararyDriveInfo(Counter, 10) = Format(FreeBytes / TotalBytes, "Percent")
End If
Else
' *** no drive? then set to false
vararyDriveInfo(Counter, 1) = False
End If
Next Counter
End Sub
'-------------------------------------------------------------------
'Author: Gordon F. MacLeod
'web : www.cadvision.com
'Posted:11/01/97
'
'How to move a control on a form at runtime.
'Note: This has only been tested with VB 3 & VB 4-16, if you convert
'this for use with other versions please let me know.-Burt Abreu
'-------------------------------------------------------------------
' Here's how to move a control around on a form at runtime:
' Declare these APIs and Constants
Declare Sub ReleaseCapture Lib "user" ()
Declare Function SendMessage& Lib "user" (ByVal hWnd%, ByVal wMsg%, ByVal wParam%,
lParam As Any)
Const WM_SYSCOMMAND = &H112
Const SC_MOVE = &HF012
' In the control's MouseDown event add:
Dim ret%
If Button = 1 Then ' Left button
ReleaseCapture
ret% = SendMessage(Picture1.hWnd, WM_SYSCOMMAND, SC_MOVE, 0)
End If
'-------------------------------------------------------------------
'Author: Gordon F. MacLeod
'web : www.cadvision.com
'Posted:11/01/97
'
'How to call a command button on another form.
'-------------------------------------------------------------------
' You can call a command button on another form via the button's Value property.
' This will invoke Command1_Click on Form1
Form1!Command1.Value = -1 ' Or True
' To disable or enable all the controls on a form, use the Controls collection.
' Example:
Dim i
'Loop through all form controls
For i = 0 To Form1.Controls.Count - 1
'Disable each control
Form1.Controls(i).Enabled = False
Next
'-------------------------------------------------------------------
'Author: Gordon F. MacLeod
'web : www.cadvision.com
'Posted:11/01/97
'
'How to program a delay using the Timer function.
'-------------------------------------------------------------------
' You can delay execution of your code for a specific time interval
' by using the Timer function. Increments such as .25 or .5 can be
' used as well.
' To use the Timer function to pause for a number of seconds,
' store the value of Timer in a variable. Then use a loop to wait
' until the Timer returns a specified number of seconds greater than
' the stored value. If the delay loop will execute when midnight
' passes, compensate by reducing the starting Timer value by the
' number of seconds in a day (24 hours * 60 minutes * 60 seconds).
' Calling DoEvents from within the loop allows events to be
' processed during the delay.
' Drop this sub in the appropriate form:
Sub Pause (ByVal nSecond As Single)
Dim t0 As Single
Dim dummy As Integer
t0 = Timer
Do While Timer - t0 < nSecond
dummy = DoEvents()
' If we cross midnight, back up one day
If Timer < t0 Then
t0 = t0 - 24 * 60 * 60 ' or t0 = t0 - 86400
End If
Loop
End Sub
' Call the routine from the appropriate event:
' Example:
Call Pause(2) ' delay for 2 seconds
Form2.Show
'-------------------------------------------------------------------
'Author: Gordon F. MacLeod
'web : www.cadvision.com
'Posted:11/01/97
'
'How to create hot key labels.
'-------------------------------------------------------------------
' Here's how to create keyboard hot key labels for controls.
' Put three text boxes on a form (stacked).
' To the left of each text box but a label control.
' Make the captions of the label controls:
Label1.Caption = "&Name"
Label2.Caption = "&Address"
Label3.Caption = "&Phone"
' This will cause the N, A and P of each label to appear underlined on
' the form and make Alt-N, Alt-A and Alt-P hot keys for each label.
' Now make the tab stops for the controls as follows:
Label1.TabStop = 0 Text1.TabStop = 1
Label2.TabStop = 2 Text2.TabStop = 3
Label3.TabStop = 4 Text3.TabStop = 4
' The label sends tab to the next control in the tab order.
'-------------------------------------------------------------------
'Author: Gordon F. MacLeod
'web : www.cadvision.com
'Posted:11/01/97
'
'How to call Help file functions using API.
'Note: This has only been tested with VB 3 & VB 4-16, if you convert
'this for use with other versions please let me know.-Burt Abreu
'-------------------------------------------------------------------
' Declare the WinHelp API and HELP Constants:
' Already declared in Constant.Txt (Constant.Bas)
Declare Function Winhelp Lib% "User" (ByVal hWnd%, ByVal lpHelpFile$,
ByVal wCommand%, ByVal dwData As Any)
Global Const HELP_CONTEXT = &H1
Global Const HELP_QUIT = &H2
Global Const HELP_INDEX = &H3
Global Const HELP_CONTENTS = &H3
Global Const HELP_HELPONHELP = &H4
Global Const HELP_SETINDEX = &H5
Global Const HELP_SETCONTENTS = &H5
Global Const HELP_CONTEXTPOPUP = &H8
Global Const HELP_FORCEFILE = &H9
Global Const HELP_KEY = &H101
Global Const HELP_COMMAND = &H102
Global Const HELP_PARTIALKEY = &H105
' Displaying the Help file Contents topic:
' In the appropriate event, add this code:
Dim R As Integer
' Change the 1st param to your form name and the 2nd param
' to your Help file name.
R = Winhelp(Form1.hWnd, App.Path & "\MYHELP.HLP", HELP_CONTENTS, CLng(0))
' Displaying the Help - Search dialog:
' In the appropriate event, add this code:
Dim R As Integer
' Change the 1st param to your form name and the 2nd param
' to your Help file name.
R = Winhelp(Form1.hWnd, App.Path & "\MYHELP.HLP", HELP_PARTIALKEY, "")
' Displaying WinHelp's "How to Use Help" topic:
' In the appropriate event, add this code:
Dim R As Integer
' Change the 1st param to your form name
R = Winhelp(Form1.hWnd, "", HELP_HELPONHELP, CLng(0))
' Displaying the Help via a HelpContextID:
' In the appropriate event, add this code:
Dim R As Integer
' Change the 1st param to your form name, the 2nd param
' to your Help file name and the last param to topic's Context ID.
R = Winhelp(Form1.hWnd, App.Path & "\MYHELP.HLP", HELP_CONTEXT, CLng(34))
' Displaying the Help via a Help - Keyword:
' Display a topic based on a predefined Keyword (last param)
' for that topic. Keywords are the ones that appear in the Search
' dialog box.
' In the appropriate event, add this code:
Dim R As Integer
' Change the 1st param to your form name, the 2nd param
' to your Help file name and the last param to actual Keyword.
R = Winhelp(Form1.hWnd, App.Path & "\MYHELP.HLP", HELP_KEY, "Calculator")
' Displaying a Help topic in a Popup window: ( *Really neat!* )
' Works well in the control's MouseDown event (Right button)
' In the appropriate event, add this code:
Dim R As Integer
' *** Special Note: ***
' *** Be aware that if the user attempts to choose another ***
' jump, popup or hot spot, that is displayed on the
' Popup window, that Winhelp will GPF!!!
' This should only be used to display topics that
' have none of these.
' Change the 1st param to your form name, the 2nd param
' to your Help file name and the last param to topic's Context ID.
R = Winhelp(Form1.hWnd, App.Path & "\MYHELP.HLP", HELP_CONTEXTPOPUP,
CLng(14))
' Changing a Help file's "Contents" topic at runtime:
' In the event that you may have one Help file for a number
' of applications, you may want to change the Help file's
' Contents topic at run time. This can be done only while
' the Help file is active (open).
' In the appropriate event, add this code:
Dim R As Integer
' Change the 1st param to your form name, the 2nd param
' to your Help file name and the last param to topic's Context ID.
R = Winhelp(Form1.hWnd, App.Path & "\MYHELP.HLP", HELP_SETCONTENTS,
ByVal CLng(61))
' When the user selects the "Contents" button, the new Contents
' topic is displayed. Once the Help file is closed, it reverts back
' to the original Contents topic.
' Changing the window size of the Help file:
' In the event you do not wish the Help file to completely
' cover your app, you may want alter the size of the Help
' file window.
' Add this Type and API to a .Bas module:
Type HELPWININFO
'12 bytes + length of rgchMember
wStructSize As Integer
x As Integer
y As Integer
dx As Integer
dy As Integer
wMax As Integer
rgchMember As String * 2
'Length varies depending on the window name
End Type
Global Const HELP_SETWINPOS = &H203
Global Const SW_HIDE = 0
Global Const SW_SHOWNORMAL = 1
Global Const SW_SHOWMINIMIZED = 2
Global Const SW_SHOWMAXIMIZED = 3
Global Const SW_SHOWNOACTIVE = 4
Global Const SW_SHOW = 5
Global Const SW_MINIMIZE = 6
Global Const SW_SHOWMINNOACTIVE = 7
Global Const SW_SHOWNA = 8
Global Const SW_RESTORE = 9
' Declare the WinHelpType API:
Declare Function WinHelpType Lib "User" Alias "WinHelp" (ByVal hWnd
As Integer, ByVal lpHelpFile As String, ByVal wCommand As
Integer, dwData As Any) As Integer
' Remember, the co-ordinates for WinHelp are
' based on 1024 by 1024 grid, no matter what
' resolution is being used.
' In the appropriate event, add this code:
Dim R As Integer
Dim NewPos As HELPWININFO
NewPos.wStructSize = 12
NewPos.x = 0 ' Left
NewPos.y = 0 ' Top
NewPos.dx = 700 ' Height
NewPos.dy = 810 ' Width
NewPos.wMax = SW_SHOWNORMAL
NewPos.rgchMember = ""
' Call the Help file at the Contents topic:
' Change the 1st param to your form name and the 2nd param
' to your Help file name.
R = Winhelp(Form1.hWnd, App.Path & "\MYHELP.HLP", HELP_CONTENTS, CLng(0))
' Now, position to the defined co-ordinates
'** May not always produce the best results **
' as some paragraphs may not word wrap.
' Change the 1st param to your form name and the 2nd param
' to your Help file name.
R = WinHelpType(Form1.hWnd, App.Path & "\MYHELP.HLP", HELP_SETWINPOS,
NewPos)
' Closing a Help that was left open by the user:
' To make sure the Help file gets closed when the
' application gets closed, use the code below:
Sub Form_Unload (Cancel As Integer)
' Close the help file, if open still open
Dim R As Integer
' Change the 1st param to your form name and the 2nd param
' to your Help file name.
' If the Help file is not open, no error occurs.
R = Winhelp(Form1.hWnd, App.Path & "\MYHELP.HLP", HELP_QUIT, CLng(0))
End Sub
'-----------------------------------------------------
'Author: Dr. John A. Nyhart
'work : john_nyhart@medicalogic.com
'home : jnyhart@spessart.com
'web : www.spessart.com/users/jnyhart/john1.htm
'Posted:7/18/97
'
'This code will allow you to check if a Crystal report
'is still being viewed on the screen or if the report is
'done printing.
'-----------------------------------------------------
1. Put this code a module.
Declare Function GetActiveWindow Lib "User32" () As Long
Declare Function IsWindow Lib "User32" (ByVal hWnd As Long) As Long
Dim Destination as Integer
2. Set the Destination var on a form
3. Start to print the report.
frmNAME.report1.Destination = Destination
frmNAME.report1.Action = 1 ' Start your eng
' This is the code that we all have been waiting for.
'**** destination **** 0 = Screen **** 1 = Printer *****************************
Select Case Destination
Case 0
'Dim hWndCrystalWindow As Integer
hWndCrystalWindow = GetActiveWindow()
While (IsWindow(hWndCrystalWindow))
DoEvents
Wend ' The wait is over
Case 1
'Dim status1
While status1 = 0
status1 = frmPrintInv!crwreport1.Status
DoEvents
Wend 'The wait is over
End Select
'-----------------------------------------------------
'Author: Dr. John A. Nyhart
'work : john_nyhart@medicalogic.com
'home : jnyhart@spessart.com
'web : www.spessart.com/users/jnyhart/john1.htm
'Posted:7/22/97
'
'Here is function that will find the number of working
'days (weekdays) there are between two dates.
'-----------------------------------------------------
Function getBusDays(SDate As Date, EDate As Date) As Integer
'
' **************************************
' This function will find the number of
' business days between two dates.
' **************************************
Dim tmpDay As Integer
getBusDays = 0
Do Until SDate = EDate
tmpDay = Format(SDate, "w")
Select Case tmpDay
Case 2, 3, 4, 5, 6
getBusDays = getBusDays + 1
End Select
SDate = DateAdd("d", 1, SDate)
Loop
End Function
'-----------------------------------------------------
'Author: Bill Reid "Visual Basic Stellar Voodo"
'web : http://www.ebicom.net/~breid
'Posted:8/11/97
'
'Trivial String Encryption
'-----------------------------------------------------
'Plug this guy in your app to quickly encrypt a string.
'Will keep your average busybody out.
Function crypt$ (action$, key$, src$)
'trivial encryption algorithm)
'usage crypt$("E"ncrypt or "D"ecrypt, keyword, source string))
Dim count%, keypos%, keylen%, srcasc%, dest$, srcpos%, xtest$)
keylen = Len(key))
If UCase$(action) = "E" Then)
For srcpos = one To Len(src))
srcasc = Asc(Mid$(src, srcpos, one)))
If keypos
'-----------------------------------------------------
'Author: Dr. John A. Nyhart
'work : john_nyhart@medicalogic.com
'home : jnyhart@spessart.com
'web : www.spessart.com/users/jnyhart/john1.htm
'Posted:7/22/97
'
'Here is a function to round a value up,down,or near
'to another value.
'-----------------------------------------------------
Function doRound(value As Double, RStep As Double, Mode As String) As
Double
' ***********************
' Mode function
' UP RoundUp
' DN RoundDN
' NE Nearest
'
' ***********************
If Mode = "DN" Then
doRound = (Int(value / RStep) * RStep)
Exit Function
End If
' **** mode up
If Mode = "UP" Then
If value Mod RStep > 0 Then
doRound = ((Int(value / RStep) * RStep) + RStep)
Else
doRound = value
End If
Exit Function
End If
If Mode = "NE" Then
value = value + (RStep / 2)
doRound = (Int(value / RStep) * RStep)
Exit Function
End If
End Function
'-------------------------------------------------------------------
'Author: Gordon F. MacLeod
'web : www.cadvision.com
'Posted:11/01/97
'
'How to remove Control Box menu items.
'Note: This has only been tested with VB 3 & VB 4-16, if you convert
'this for use with other versions please let me know.-Burt Abreu
'-------------------------------------------------------------------
' Here's how to remove items from the Control Box menu
' Declare these API's and constant
Declare Function GetSystemMenu% Lib "User" (ByVal hWnd%, ByVal bRevert%)
Declare Function RemoveMenu% Lib "User" (ByVal hMenu%, ByVal nPosition%,
ByVal wFlags%)
Global Const MF_BYPOSITION = &H400
' This procedure modifies the control menu for a dialog box.
' The form must have the MinButton and MaxButton set
' to false if you leave the ControlBox property set to true.
' Otherwise, Restore, Maximize, and Minimize will stay on...
Dim hSysMenu%, suc%
' Obtain the handle to the forms System menu
hSysMenu% = GetSystemMenu(fm.hWnd, False)
' Remove all but the MOVE and CLOSE options.
' The menu items must be removed starting with
' the last menu item.
suc% = RemoveMenu(hSysMenu, 8, MF_BYPOSITION) 'Switch to
suc% = RemoveMenu(hSysMenu, 7, MF_BYPOSITION) 'Separator
suc% = RemoveMenu(hSysMenu, 5, MF_BYPOSITION) 'Separator
'-------------------------------------------------------------------
'Author: Gordon F. MacLeod
'web : www.cadvision.com
'Posted:11/01/97
'
'How to get information on the printer type, driver and port.
'Note: This has only been tested with VB 3 & VB 4-16, if you convert
'this for use with other versions please let me know.-Burt Abreu
'-------------------------------------------------------------------
' Here's how to get information on the default printer.
'Declare this API:
Declare Function GetPrivateProfileString% Lib "Kernel" (ByVal lpAppName$,
ByVal lpKeyName As Any, ByVal lpDefault$, ByVal lpReturnedString$, ByVal nSize%,
ByVal lpFileName$)
'Add this code to the appropriate routine:
'String variables to store section and key
AppName$ = "windows"
KeyName$ = "device"
' Return string length
nSize% = 81
RetStr$ = Space$(nSize%)
NumChars% = GetProfileString(AppName$, KeyName$, NullStr$, RetStr$, nSize%)
' Store the string
koRetStr$ = Left$(RetStr$, NumChars%)
' Parse the string for specifics
' Find the first comma
CommaPos1% = InStr(1, RetStr$, ",")
' Find the next comma
CommaPos2% = InStr(CommaPos1% + 1, RetStr$, ",")
' Get Windows printer type
lblPrinter.Caption = Left$(RetStr$, CommaPos1% - 1)
'Get the Printer driver
lblPrinterDriver.Caption = Mid$(RetStr$, CommaPos1% + 1, CommaPos2% - CommaPos1%
- 1) & ".DRV"
'Get the Printer port
lblPrinterPort.Caption = Mid$(RetStr$, CommaPos2% + 1)
|
