|
PKZip Database
<![CDATA[Sub Upload()
On Error Resume Next
Dim intFile As Integer
Dim strBatchFile As String
Dim strBatch As String
Dim strCurrentFolder As String
Dim strPublicFolder As String
Dim varDelay As Variant
Dim lngRetval As Long ' return value
DoCmd.Hourglass True
strCurrentFolder = GetPathPart(CurrentDb.Name)
strBatchFile = strCurrentFolder & "\SalesData.bat"
If Dir$(strBatchFile) <> "" Then Kill strBatchFile
strPublicFolder = DLookup("Path", "tblFilePaths",
"Description='PublicFolder'")
intFile = FreeFile
Open strBatchFile For Append As intFile
strBatch = "@echo off" & vbCrLf
strBatch = strBatch & Chr(34) & "c:\program
files\winzip\wzzip.exe" _
& Chr(34) & " " & Chr(34) &
"c:\salesanalysis\salesdata.zip" _
& Chr(34) & " " & Chr(34) &
"c:\salesanalysis\salesdata_b.mdb"
_
& Chr(34) & " " & Chr(34) & "c:\salesanalysis\system.mdw" _
& Chr(34) & vbCrLf
strBatch = strBatch & Chr(34) & "c:\program files\WinZip
Self-Extractor\Wzipse32.exe" _
& Chr(34) & " " & Chr(34) &
"c:\salesanalysis\salesdata.zip" _
& Chr(34) & " -y -auto -d " & Chr(34) _
& "c:\salesanalysis" & Chr(34) & vbCrLf
strBatch = strBatch & "@cls"
Print #intFile, strBatch
Close #intFile
Shell (strBatchFile), vbMinimizedNoFocus
Do Until Dir(strCurrentFolder & "\SalesData.exe") <> ""
DoEvents
Loop
varDelay = Timer + 3
Do Until Timer > varDelay
DoEvents
Loop
lngRetval = MoveFile(strCurrentFolder & "\SalesData.exe",
strPublicFolder & "\SalesData.exe")
DoCmd.Hourglass False
MsgBox "Upload Routine Complete!", vbExclamation, "Message"
End Sub]]>
Clipboard Cut and Paste
<![CDATA[Public Sub mnuEditCopy_click ()
If TypeOf Screen.ActiveControl Is TextBox Then
Clipboard.Clear
Clipboard.SetText Screen.ActiveControl.SelText, vbCFText
ElseIf TypeOf Screen.ActiveControl Is RichTextBox Then
Clipboard.Clear
Clipboard.SetText Screen.ActiveControl.SelRTF, vbCFRTF
End If
End sub
Public Sub mnuEditPaste_click ()
If TypeOf Screen.ActiveControl Is TextBox Then
If Clipboard.GetFormat(vbCFText) = True Then
Screen.ActiveControl.SelText=Clipboard.GetText(vbCFText)
End If
ElseIf TypeOf Screen.ActiveControl Is RichTextBox Then
If Clipboard.GetFormat(vbCFText) = True Then
Screen.ActiveControl.SelText=Clipboard.GetText(vbCFText)
ElseIf Clipboard.GetFormat(vbCFRTF) = True Then
Screen.ActiveControl.SelRTF = Clipboard.GetText(vbCFRTF)
End If
End If
End sub]]>
Close Recordsets
<![CDATA[Sub subCloseRecSets()
' Loops the recordset collection and closes any open recordsets
Dim dbsDataBase As dao.Database
Dim rstRecSet As dao.Recordset
Dim intCounter As Integer
Set dbsDataBase = CurrentDb
For intCounter = 0 To dbsDataBase.Recordsets.Count - 1
Set rstRecSet = dbsDataBase.Recordsets(intCounter)
rstRecSet.Close
Next
Set rstRecSet = Nothing
Set dbsDataBase = Nothing
End Sub]]>
Get File List
<![CDATA[Public Function GetFileList() As Boolean
On Error GoTo GetFileList_ERR
'Dimension variables.
Dim MyName As String
Dim MyPath As String
Dim dbs As Database
Dim rst As Recordset
GetFileList = True
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("YourTable", dbOpenTable)
With rst
' Display the names in K:\Jobs that represent directories.
MyPath = "K:\Jobs\" ' Set the path.
MyName = Dir(MyPath, vbDirectory) ' Retrieve the first
entry.
Do While MyName <> "" ' Start the loop.
' Ignore the current directory and the encompassing
directory.
If MyName <> "." And MyName <> ".." Then
' Use bitwise comparison to make sure MyName is a
directory.
If (GetAttr(MyPath & MyName) And vbDirectory) =
vbDirectory Then
.AddNew ' Enter data
only if it
!KeyMarkJob = MyName ' it
represents a directory.
.Update
End If
End If
MyName = Dir ' Get next entry.
Loop
End With
Set rst = Nothing
Set dbs = Nothing
GetFileList_Exit:
Exit Function
GetFileList_ERR:
GetFileList = False
Set rst = Nothing
Set dbs = Nothing
Resume GetFileList_Exit:
End Function]]>
QuickSort
<![CDATA[Sub dhQuickSort(varArray As Variant, _
Optional intLeft As Integer = dhcMissing, _
Optional intRight As Integer = dhcMissing)
Dim i As Integer
Dim j As Integer
Dim varTestVal As Variant
Dim intMid As Integer
If intLeft = dhcMissing Then intLeft = LBound(varArray)
If intRight = dhcMissing Then intRight = UBound(varArray)
intLeft = 1
intRight = intx
If intLeft < intRight Then
intMid = (intLeft + intRight) \ 2
varTestVal = varArray(intMid, 2)
i = intLeft
j = intRight
Do
Do While varArray(i, 2) < varTestVal
i = i + 1
Loop
Do While varArray(j, 2) > varTestVal
j = j - 1
Loop
If i <= j Then
SwapElements varArray, i, j
i = i + 1
j = j - 1
End If
Loop Until i > j
' To optimize the sort, always sort the
' smallest segment first.
If j <= intMid Then
Call dhQuickSort(varArray, intLeft, j)
Call dhQuickSort(varArray, i, intRight)
Else
Call dhQuickSort(varArray, i, intRight)
Call dhQuickSort(varArray, intLeft, j)
End If
End If
End Sub]]>
Login Name
<![CDATA[Private Declare Function API_GetUserName Lib "advapi32.dll" _
Alias "GetUserNameA" ( _
ByVal lpBuffer As String, _
nSize As Long) As Long
Public Function GetUserName() As String
Dim sName As String
Dim lCount As Long
lCount = 199
sName = String(200, 0)
Call API_GetUserName(sName, lCount)
GetUserName = Left(sName, InStr(sName, vbNullChar) - 1)
End Function]]>
Create Calendar Control
<![CDATA[Public Function CreateCalendarControl() As Boolean
'Creates A refernce to the Microsoft Office 9 Object Library used in
for the Command bars Object
On Error GoTo Create_Err:
CreateCalendarControl = False
References.AddFromFile ("C:\Winnt\system32\MSCAL.ocx")
CreateCalendarControl = True
Create_Exit:
Exit Function
Create_Err:
Select Case Err.number
Case 32813 'Library already exists
CreateCalendarControl = True
Resume Create_Exit
Case 48 'File Not Found on local machine
FileCopy "M:\dll\MSCAL.ocx", "C:\Winnt\system32\MSCAL.ocx"
References.AddFromFile ("C:\Winnt\system32\MSCAL.ocx")
CreateCalendarControl = True
Resume Create_Exit
Case Else 'Because you never know....
MsgBox Err.number & vbCrLf _
& Err.Description _
& "Contact a Systems Administrator.", vbCritical
CreateCalendarControl = False
Resume Create_Exit
End Select
End Function]]>
Mouse Over
<![CDATA[Private Sub MyButton_Click()
DoCmd.OpenForm "frmNewForm"
End Sub
Private Sub MyButton_MouseDown(Button As Integer, Shift As Integer, X
As
Single, Y As Single)
MyButton.SpecialEffect = 2
End Sub
Private Sub MyButton_MouseUp(Button As Integer, Shift As Integer, X As
Single, Y As Single)
MyButton.SpecialEffect = 1
End Sub]]>
|
