API

Emily

http://www.mentalis.org/index2.shtml

API 的使用參考 1:

API-Guide

API-Guide has over 900 functions, all documented, and explained with an example. Several functions also have a dotNET equivalent and dotNET example code.

API-Guide 3.7 download 2.2M - Orginal Link

你需要有 Microsoft Visual Basic 5.0 Runtimes，如果已裝 VB 不需要下載

http://download.microsoft.com/download/vb50pro/utility/1/win98/EN-US/Msvbvm50.exe

ExcelHome 直接下載: agsetup(API-Guide 3.7).part1~ 7

6QtgNWVr.rar (213.46 KB, 下载次数: 534)

2005-7-24 09:38 上传

点击文件名下载附件
API

[此贴子已经被作者于2005-7-24 16:51:02编辑过]

Emily

'---------------------------------------------------------------------------------------
' Module    : basMain
' DateTime  : 02/09/2004 22:23
' Author    : Ivan F Moala
' Purpose   :
'---------------------------------------------------------------------------------------
Option Explicit

'//
Public Declare Function ShellExecute _
    Lib "shell32.dll" _
        Alias "ShellExecuteA" ( _
            ByVal Hwnd As Long, _
            ByVal lpOperation As String, _
            ByVal lpFile As String, _
            ByVal lpParameters As String, _
            ByVal lpDirectory As String, _
            ByVal nShowCmd As Long) _
As Long

'// Properties API
Private Type SHELLEXECUTEINFO
    cbSize       As Long
    fMask        As Long
    Hwnd         As Long
    lpVerb       As String
    lpFile       As String
    lpParameters As String
    lpDirectory  As String
    nShow        As Long
    hInstApp     As Long
    lpIDList     As Long
    lpClass      As String
    hkeyClass    As Long
    dwHotKey     As Long
    hIcon        As Long
    hProcess     As Long
End Type

Private Declare Function ShellExecuteEx _
    Lib "shell32.dll" ( _
        Prop As SHELLEXECUTEINFO) _
As Long

Public Function fnGetPropDlg(strFilepath As String) As Long
Dim Prop As SHELLEXECUTEINFO

With Prop
    .cbSize = Len(Prop)
    .fMask = &HC
    .Hwnd = 0&
    .lpVerb = "properties"
    .lpFile = strFilepath
End With

fnGetPropDlg = ShellExecuteEx(Prop)

End Function

Sub Test()
Dim vFile As Variant

vFile = Application.GetOpenFilename
If TypeName(vFile) = "Boolean" Then Exit Sub

fnGetPropDlg CStr(vFile)

End Sub

[此贴子已经被作者于2006-10-3 12:42:46编辑过]

Emily

UserForm ICON example by Ivan F Moala LPVMd7jj.zip (31.15 KB, 下载次数: 146)

2005-7-24 18:09 上传

点击文件名下载附件

[em17]

[此贴子已经被作者于2005-7-24 18:09:17编辑过]

Emily

'Current Printer is Xerox Phaser 7300B(1F Color) on Ne00:   Port is Ne00:

Sub GetPrinter_Port()

Dim sPort, Test As String
Dim CPrinter As String
    Do Until CPrinter = Application.ActivePrinter
        CPrinter = Application.ActivePrinter
        sPort = Trim$(Mid$(ActivePrinter, InStrRev(ActivePrinter, " ") + 1))
        Application.StatusBar = "Current Printer is " & CPrinter & "   " & "Port is " & sPort
        Test = Application.Dialogs(xlDialogPrinterSetup).Show
        If Test = "False" Then
            Application.StatusBar = ""
            Exit Sub
        End If
    Loop
End Sub

[此贴子已经被作者于2006-10-3 12:47:46编辑过]

Emily

'---------------------------------------------------------------------------------------
' Module    : Module1
' DateTime  : 23/4/2006 10:43
' Author    :
' Purpose   : API Get Default Printer Name
'---------------------------------------------------------------------------------------
Private Declare Function GetProfileString Lib "kernel32.dll" Alias "GetProfileStringA" _
        (ByVal lpAppName As String, _
        ByVal lpKeyName As String, _
        ByVal lpDefault As String, _
        ByVal lpReturnedString As String, _
        ByVal nSize As Long) As Long
Function Get_DefaultPrinterName() As String
Const BUFFSIZE As Long = 254

Dim strBuffer As String * BUFFSIZE
Dim lngRetVal As Long

    lngRetVal = GetProfileString("windows", "device", ",,,", strBuffer, BUFFSIZE)
    Get_DefaultPrinterName = Left(strBuffer, InStr(strBuffer, ":"))
   
End Function

[此贴子已经被作者于2006-10-3 12:46:19编辑过]

Emily

Sub Demo()

Dim Message, Title, Default, MyValue
Message = "Enter Password: "
Title = "InputBoxDK Demo"
Default = "******"
Pwd = InputBoxDK(Message, Title, Default)

MsgBox Pwd

End Sub

' Paste in Module

Option Explicit
'////////////////////////////////////////////////////////////////////
'Password masked inputbox
'Allows you to hide characters entered in a VBA Inputbox.
'
'Code written by Daniel Klann
'March 2003
'////////////////////////////////////////////////////////////////////

'API functions to be used
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _
ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long

Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long

Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _
(ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long

Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long

Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" _
(ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long

Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) As Long

Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long

'Constants to be used in our API functions
Private Const EM_SETPASSWORDCHAR = &HCC
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5
Private Const HC_ACTION = 0

Private hHook As Long

Public Function NewProc(ByVal lngCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim RetVal
Dim strClassName As String, lngBuffer As Long

If lngCode < HC_ACTION Then
NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam)
Exit Function
End If

strClassName = String$(256, " ")
lngBuffer = 255

If lngCode = HCBT_ACTIVATE Then 'A window has been activated

RetVal = GetClassName(wParam, strClassName, lngBuffer)

If Left$(strClassName, RetVal) = "#32770" Then 'Class name of the Inputbox

'This changes the edit control so that it display the password character *.
'You can change the Asc("*") as you please.
SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0
End If

End If

'This line will ensure that any other hooks that may be in place are
'called correctly.
CallNextHookEx hHook, lngCode, wParam, lParam

End Function

Public Function InputBoxDK(Prompt, Optional Title, Optional Default, Optional XPos, _
Optional YPos, Optional HelpFile, Optional Context) As String
Dim lngModHwnd As Long, lngThreadID As Long

lngThreadID = GetCurrentThreadId
lngModHwnd = GetModuleHandle(vbNullString)

hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)

InputBoxDK = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context)
UnhookWindowsHookEx hHook

End Function

[此贴子已经被作者于2006-10-3 12:49:37编辑过]

Emily

Option Explicit

Declare Function GetDeviceCaps Lib "Gdi32" _
(ByVal hdc As Long, ByVal nIndex As Long) As Long
Declare Function GetDC Lib "User32" _
(ByVal hWnd As Long) As Long
Declare Function ReleaseDC Lib "User32" _
(ByVal hWnd As Long, ByVal hdc As Long) As Long

Function HRes() As Integer
    'Returns the horizontal resolution in pixels
    Dim lDC As Long
    lDC = GetDC(0)
    HRes = GetDeviceCaps(lDC, 8)
    ReleaseDC 0, lDC
End Function

Function VRes() As Integer
    'Returns the vertical resolution in pixels
    Dim lDC As Long
    lDC = GetDC(0)
    VRes = GetDeviceCaps(lDC, 10)
    ReleaseDC 0, lDC
End Function

Function ColorDepth() As Integer
    'Returns the color depth in bits per pixel
    Dim lDC As Long
    lDC = GetDC(0)
    ColorDepth = GetDeviceCaps(lDC, 12) _
     * GetDeviceCaps(lDC, 14)
    ReleaseDC 0, lDC
End Function

Function Colors() As Single
    'Returns the number of available colors
    Dim lDC As Long
    lDC = GetDC(0)
    Colors = 2 ^ (GetDeviceCaps(lDC, 12) _
     * GetDeviceCaps(lDC, 14))
    ReleaseDC 0, lDC
End Function

Function VRefresh() As Integer
    'Returns the vertical refresh rate in Hz
    Dim lDC As Long
    lDC = GetDC(0)
    VRefresh = GetDeviceCaps(lDC, 116)
    ReleaseDC 0, lDC
End Function

[此贴子已经被作者于2006-10-3 12:44:01编辑过]

Emily

' Module

Option Explicit

Declare Function ExitWindowsEx& Lib "user32" (ByVal uFlags&, ByVal wReserved&)
Global Const EWX_LOGOFF = 0
Public IdleTime As Date
Dim Action&

Sub StartTimer()
    IdleTime = Now + TimeValue("00:05:00")    ' ²{¦b³]©w 5 Mins
    Application.OnTime IdleTime, "LogOff"
End Sub

Sub DisableTimer()
    On Error Resume Next
    Application.OnTime EarliestTime:=IdleTime, Procedure:="LogOff", Schedule:=False
End Sub

Sub LogOff()
    Application.DisplayAlerts = False
    Action = ExitWindowsEx(EWX_LOGOFF, 0&)
    Application.Quit
End Sub

'----

' ThisWorkBook

Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
    Run "DisableTimer"
    Run "StartTimer"
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Excel.Range)
    Run "DisableTimer"
    Run "StartTimer"
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Run "DisableTimer"
    Run "StartTimer"
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Run "DisableTimer"
End Sub

[此贴子已经被作者于2006-10-26 18:21:31编辑过]

wfy_lhl

非常不错，我有错就改