EasyApi For VB (1)

簡易 Windows API For VB 範例(一)

回首頁

分類	標題	大意	作者	日期
圖形處理	加快逐點繪圖速度	SetPixel API 函數的使用	老怪	1998/10/28
圖形處理	取代 Point & PSet 的 API 函數	GetPixel & SetPixel API 函數	老怪	1998/11/18
圖形處理	調整 PictureBox 大小配合 MCI 輸出	mciSendString	老怪	1998/2/9
聲音處理	Wave 檔的播放	SndPlay	鄭郁霖	1998/8/16
視窗界面	讓Form一直在最上層	SetWindowPos	網中英	1998/9/15
視窗界面	隨桌面設定調整表單大小	解析度與大小字型設定的讀取	老怪	1998/11/12
視窗界面	Form 上的畫面(含 Control) 的輸出	BitBlt API 函數的使用	老怪	1998/11/16
視窗界面	截取螢幕的程式		老怪	1999/1/26
視窗界面	用 ToolBar 做 IE 浮動按鈕		Y.J.Chen	1999/2/1
週邊訊息	查出所有磁碟機裝置型態	GetDriveTypeA	網中英	1998/9/11
地區設定	如何取得System Date Format	GetLocaleInfo	老怪	1998/12/8
系統設定	如何判斷 Windows OS 版本	GetVersionEx	老怪	1998/12/10
系統設定	如何用VB建立捷徑(ShortCut)		轉出	1998/6/25
鍵盤處理	如何關掉ctrl+alt+del 按鍵功能		璉璉	1998/12/19
程式執行	依副檔名開啟 Windows 登錄程式	GetAppCommandString	老怪	1999/1/31
程式執行	在 VB 中啟動 Internet Browser		老怪	1999/5/13

簡易 Windows API For VB 範例說明

本範例歡迎非營利性個人及組織轉載使用，營利之利用請先徵得本人之同意，來信註明使用方式及回覆地址。
不管 VB 怎麼簡易親合又功能眾多，但總有計窮的時候，本範例不在帶領大家一探 API 的堂奧，因為我也不是很懂 API 。但搜集一些其他人簡易好用的 API 範例提供大家參考，或許能解決你些小問題。
如果你有其他 API 問題，請不要問我，因為多半我答不出來，會讓你很失望的。

加快逐點繪圖速度

Chang Lee. 撰寫於文章

如有一個檔案內容為 R,G,B, 值，我將它讀入成一個陣列例如 : a(1).....a(200)，再用 Pset 的方式一點一點的顯示,這樣非常的慢,請問有沒有快一點的方法??!!!!!!？

老怪答：

將繪圖元件 Visible=False 再畫，畫完再 Visible = True。
使用 SetPixel API 函數。
範例如下：
Option Explicit

Private Declare Function SetPixel Lib "gdi32" _
        (ByVal hdc As Long, ByVal x As Long, _
        ByVal y As Long, ByVal crColor As Long) As Long
'hdc 繪圖物件的 hdc 屬性
'x 繪圖物件圖點 X 軸座標
'y 繪圖物件圖點 Y 軸座標
'crColor 圖點的色彩值
'測試本範例請於 Form 上布置 Command1，Picture1
Private Sub Command1_Click()
Dim I As Integer, J As Integer
    With Picture1
        .Visible = False
        .AutoRedraw = True
        For I = 0 To 255
            For J = 0 To 255
                SetPixel .hdc, I, J, RGB(I, J, 0)
            Next
        Next
        .AutoRedraw = False
        .Visible = True
    End With
End Sub

Private Sub Form_Load()
    Form1.ScaleMode = 3
    With Picture1
        .ScaleMode = 3
        .Width = 255 + .Width - .ScaleWidth
        .Height = 255 + .Height - .ScaleHeight
    End With

End Sub

讓Form一直在最上層

同情我就給我分撰寫於文章

請問一下, 要怎樣才能讓Form一直在最上層啊，就是即使lostfocus也不會被其他的視窗擋住。

寄件者: 網中英新聞群組: tw.bbs.comp.language

又要借調 Windows API 這個大寶庫啦.

'*** 宣告API ***
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long,
ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx
As
Long, ByVal cy As Long, ByVal wFlags As Long) As Long

'*** 使用 ***
R = SetWindowPos(Form1.hwnd, -1, 0, 0, 0, 0, 3) 'Set always on top

'*** 還原 ***
R = SetWindowPos(Form1.hwnd, -2, 0, 0, 0, 0, 3) 'Set to normal
R = SetWindowPos(Me.hWnd, -1, 0, 0, 0, 0, 0) 浮動

回索引

Private Declare Function GetDriveTypeA Lib "kernel32" (ByVal nDrive As
String) As Long

Private Sub Command1_Click()
T = Chr(8)
For a = 1 To 26
D = Chr(a + 64) & ":\"
R = GetDriveTypeA(D)
Y=True
Select Case R
    Case 2
      Msg = D & T & " 軟碟機"
    Case 3
      Msg = D & T & " 硬碟機"
    Case 4
      Msg = D & T & " 網路上的磁碟機"
    Case 5
      Msg = D & T & " 光碟機"
    Case Else
      Y=False
End Select
If Y Then List1.AddItem Msg
Next
End Sub

回索引

隨桌面設定調整表單大小

'本範例在示範如何以 API 函數取出桌面大小及大、小字型的設定，
'以調整程式視窗的畫面，使程式不因螢幕設定而產生太大的差異。
'測試本範例請於 Form 上布置任意數量及型態之控制項，以測試效果。
'本範例不保證適用所有控制項，尤其是外建控制項，須做例外處理。
'如果你使用本範例並決定製成安裝程式前，請刪除 App.Path 裏的 Screenst.ini
檔，
'並把程式在編譯前再執行一次，以產生最後確定的 Screenst.ini 檔，並把此檔
'Include 進你的安裝程式，一起散發給使用者，如此 Screenst.ini 才會記錄你在
'設計時的螢幕設定，並配合使用者的螢幕設定做自我調整。

Option Explicit

'以下 Windows 登錄資料主機碼編號
Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const HKEY_CURRENT_USER = &H80000001
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const HKEY_USERS = &H80000003
Private Const HKEY_PERFORMANCE_DATA = &H80000004
Private Const HKEY_CURRENT_CONFIG = &H80000005
Private Const HKEY_DYN_DATA = &H80000006

'以下為本程式之輔助常數宣告
'Windwos 使用者專面設定之路徑是在 HKEY_CURRENT_CONFIG 資料夾內
Private Const APP_SCREEN_HANDLE As Long = HKEY_CURRENT_CONFIG
'Windwos 使用者專面設定之副資料夾路徑
Private Const APP_SCREEN_SUBSTRING As String = "Display\Settings"
'桌面解析度的 Key Name
Private Const APP_SCREEN_RESOLUTION As String = "Resolution"
'SmallFont 及 LargeFont 記錄的 KeyName
Private Const APP_FONT_WIDTH As String = "DPILogicalX"
Private Const APP_FONT_HEIGHT As String = "DPILogicalY"
'以下為本程式自訂節區及 KeyName 的常數宣告。
Private Const APP_SCREEN_WIDTH As String = "ScreenWidth"
Private Const APP_SCREEN_HEIGHT As String = "ScreenHeight"
Private Const USER_APP_NAME As String = "Screenst.ini"
Private Const SCREEN_SECTION_NAME As String = "ScreenSetting"

'記錄字型大小及螢幕解析度的自訂型態變動
Private Type ScreenSet
    Width As Single
    Height As Single
    DPILogicalX As Integer
    DPILogicalY As Integer
End Type

'取得 Windows 登錄檔節區代碼之 API 函數
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" _
        (ByVal hKey As Long, ByVal lpSubKey As String, _
        phkResult As Long) As Long

'取得 Windows 登錄檔節區內 KeyValue API 函數
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias _
        "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName _
        As String, ByVal lpReserved As Long, lpType As Long, _
        lpData As Any, lpcbData As Long) As Long

'將節區資料一次寫入取得 Windows 登錄檔之 API 函數
Private Declare Function WritePrivateProfileSection Lib "kernel32" Alias _
        "WritePrivateProfileSectionA" (ByVal lpAppName As String, ByVal _
        lpString As String, ByVal lpFileName As String) As Long

'取得 Windows 登錄檔某 KeyValue(限於數值) 之 API 函數
Private Declare Function GetPrivateProfileInt Lib "kernel32" Alias _
        "GetPrivateProfileIntA" (ByVal lpApplicationName As String, _
        ByVal lpKeyName As String, ByVal nDefault As Long, _
        ByVal lpFileName As String) As Long

'記錄檔裏的螢幕設定
Dim OldSetting As ScreenSet
'目前的螢幕設定
Dim NowSetting As ScreenSet
'Screenst.ini 的路徑及檔名
Dim IniPath As String

'取得目前 Windows 螢幕設定的自訂函數
Private Function GetSystemScreenSetting(ByRef SWidth As Single, _
        ByRef SHeight As Single, ByRef DPIX As Integer, _
        ByRef DPIY As Integer)
Dim ReturnHandle As Long, ReturnCheck As Long
Dim ValueType As Long, DataLength As Long
Dim ReturnData As String, Name As String
    '取得 Display\Settings 的編號
    Name = APP_SCREEN_SUBSTRING
    ReturnCheck = RegOpenKey(APP_SCREEN_HANDLE, Name, ReturnHandle)

    '取得螢幕解析度設定資料的長度
    Name = APP_SCREEN_RESOLUTION
    ReturnCheck = RegQueryValueEx(ReturnHandle, Name, ByVal 0, _
            ValueType, ByVal vbNullString, DataLength)
    '依資料的長度決定接收字串長度
    ReturnData = String(DataLength, Chr(0))
    '取得螢幕解析度設定的 Value
    ReturnCheck = RegQueryValueEx(ReturnHandle, Name, ByVal 0, _
            ValueType, ByVal ReturnData, DataLength)
    '除去尾巴的 VbNull 字元
    ReturnData = Left(ReturnData, InStr(ReturnData, Chr(0)) - 1)
    '螢幕寬度
    SWidth = CSng(Left(ReturnData, InStr(1, ReturnData, ",") - 1))
    '螢幕高度
    SHeight = CSng(Right(ReturnData, Len(ReturnData) - InStr(1, ReturnData,
",")))

    '取得螢幕字型資料的長度
    Name = APP_FONT_WIDTH
    ReturnCheck = RegQueryValueEx(ReturnHandle, Name, ByVal 0, _
            ValueType, ByVal vbNullString, DataLength)
    '依資料的長度決定接收字串長度
    ReturnData = String(DataLength, Chr(0))
    '取得螢幕字型設定的 Value
    ReturnCheck = RegQueryValueEx(ReturnHandle, Name, ByVal 0, _
            ValueType, ByVal ReturnData, DataLength)
    '除去尾巴的 VbNull 字元
    ReturnData = Left(ReturnData, InStr(ReturnData, Chr(0)) - 1)
    '字型寬度
    DPIX = CInt(ReturnData)

    '取得螢幕字型資料的長度
    Name = APP_FONT_HEIGHT
    ReturnCheck = RegQueryValueEx(ReturnHandle, Name, ByVal 0, _
            ValueType, ByVal vbNullString, DataLength)
    '依資料的長度決定接收字串長度
    ReturnData = String(DataLength, Chr(0))
    '取得螢幕字型設定的 Value
    ReturnCheck = RegQueryValueEx(ReturnHandle, Name, ByVal 0, _
            ValueType, ByVal ReturnData, DataLength)
    '除去尾巴的 VbNull 字元
    ReturnData = Left(ReturnData, InStr(ReturnData, Chr(0)) - 1)
    '字型高度
    DPIY = CInt(ReturnData)
End Function

'寫入 Windows 螢幕設定檔的自訂函數
Private Sub CreatAppScreenSetting(ByRef SWidth As Single, _
        ByRef SHeight As Single, ByRef DPIX As Integer, _
        ByRef DPIY As Integer)
Dim SecString As String
    '設定寫入字串
    SecString = APP_SCREEN_WIDTH & "=" & Trim(Str(SWidth)) & Chr(0)
    SecString = SecString & APP_SCREEN_HEIGHT & "=" & Trim(Str(SHeight)) &
Chr(0)
    SecString = SecString & APP_FONT_WIDTH & "=" & Trim(Str(DPIX)) & Chr(0)
    SecString = SecString & APP_FONT_HEIGHT & "=" & Trim(Str(DPIY)) & Chr(0)
    SecString = SecString & Chr(0)

    '寫入節區資料
    WritePrivateProfileSection SCREEN_SECTION_NAME, SecString, IniPath
End Sub

Private Sub Form_Load()
    '設定螢幕記錄檔的路徑及名稱
    IniPath = App.Path & "\" & USER_APP_NAME

    '執行取得螢幕設定自訂函數
    GetSystemScreenSetting NowSetting.Width, NowSetting.Height, _
            NowSetting.DPILogicalX, NowSetting.DPILogicalY

    '如果螢幕設定檔不存在，則把目前螢幕設定寫入設定檔
    If Dir(App.Path & "\" & USER_APP_NAME) = "" Then
        CreatAppScreenSetting NowSetting.Width, NowSetting.Height, _
            NowSetting.DPILogicalX, NowSetting.DPILogicalY
    End If

    '從設定檔讀入螢幕設定
    GetAppScreenSetting OldSetting.Width, OldSetting.Height, _
            OldSetting.DPILogicalX, OldSetting.DPILogicalY

    '如果目前螢幕長寬設定與設定檔不符，則進行控制項大小調整
    If (NowSetting.Width <> OldSetting.Width) Or (NowSetting.Height <>
OldSetting.Height) Then
        ResetControlSize NowSetting.Width, NowSetting.Height, _
                OldSetting.Width, OldSetting.Height
    End If

    '如果目前螢幕字型設定與設定檔不符，則依字型進行控制項大小調整
    If (NowSetting.DPILogicalX <> OldSetting.DPILogicalX) Or
(NowSetting.DPILogicalY <> OldSetting.DPILogicalY) Then
        ResetFontSize NowSetting.DPILogicalX, NowSetting.DPILogicalY, _
                OldSetting.DPILogicalX, OldSetting.DPILogicalY
    End If
End Sub

'取得設定檔之自訂函數
Private Sub GetAppScreenSetting(ByRef SWidth As Single, _
        ByRef SHeight As Single, ByRef DPIX As Integer, _
        ByRef DPIY As Integer)

    SWidth = GetPrivateProfileInt(SCREEN_SECTION_NAME, APP_SCREEN_WIDTH, 0,
IniPath)
    SHeight = GetPrivateProfileInt(SCREEN_SECTION_NAME, APP_SCREEN_HEIGHT,
0, IniPath)
    DPIX = GetPrivateProfileInt(SCREEN_SECTION_NAME, APP_FONT_WIDTH, 0,
IniPath)
    DPIY = GetPrivateProfileInt(SCREEN_SECTION_NAME, APP_FONT_HEIGHT, 0,
IniPath)
End Sub

'依螢幕解析度調整控制項之自訂函數
Private Sub ResetControlSize(ByVal NWidth As Single, _
        ByVal NHeight As Single, ByVal OWidth As Integer, _
        ByVal OHeight As Integer)
Dim XScale As Single
Dim YScale As Single
Dim OldWindowsState As Single
Dim I As Integer

    '換算新視窗與原視窗大小之正向比例
    XScale = NWidth / OWidth
    YScale = NHeight / OHeight

    '如該控制項沒有沒有列舉之屬性則跳下一個
    On Error Resume Next
    With Me
        OldWindowsState = .WindowState
        '螢幕在最大化及最小化時無法進行移動及調整，故須先將其視窗設為一般。
        .WindowState = 0
        .Move .Left * XScale, .Top * YScale, .Width * XScale, .Height *
YScale
        '還原 WindowsState
        .WindowState = OldWindowsState
        .FontSize = Int(Me.FontSize * (XScale + YScale) / 2)
    End With
    '移動並調整控制項大小，如有屬性較例外之控制項，
    '須以 Case "Object Name" 方式做個別處理。
    For I = 0 To Me.Controls.Count - 1
        With Me.Controls(I)
            Select Case TypeName(Me.Controls(I))
                Case "Line"
                    .X1 = .X1 * XScale
                    .X2 = .X2 * XScale
                    .Y1 = .Y1 * YScale
                    .Y2 = .Y2 * YScale
                Case Else
                    .Move .Left * XScale, .Top * YScale, _
                    .Width * XScale, .Height * YScale
                    .FontSize = Int(.FontSize * (XScale + YScale) / 2)
            End Select
        End With
    Next
End Sub

'依螢幕字型設定調整控制項之自訂函數
'之所以螢幕字型大小不同時，控制項須再調整的原因是：
'當字型設定不同時，VB Screen 物件的 Twip 與 Pixel 轉換值會不同，
'當使用 SmallFont 時，Screen.TwipsPerPixelX & TwipsPerPixelY 是 15
'當使用 LargeFont 時，Screen.TwipsPerPixelX & TwipsPerPixelY 是 12
'雖然螢幕解析度完全一樣，但對 Form 這種以 Twip 為單位的物件，自然會在
'不同的字型設定下有不同的大小。所以為了排除在不同字型設定下有不同的畫面，
'依字型重設控制項大小是必須的。
Private Sub ResetFontSize(ByVal NDPIX As Single, _
        ByVal NDPIY As Single, ByVal ODPIX As Integer, _
        ByVal ODPIY As Integer)
Dim XScale As Single
Dim YScale As Single
Dim OldWindowsState As Single
Dim I As Integer

    '換算原視窗大小與新視窗大小的比例
    XScale = ODPIX / NDPIX
    YScale = ODPIY / NDPIY

    '如該控制項沒有沒有列舉之屬性則跳下一個
    On Error Resume Next
    With Me
        OldWindowsState = .WindowState
        .WindowState = 0
        .Move .Left * XScale, .Top * YScale, .Width * XScale, .Height *
YScale
        .WindowState = OldWindowsState
        .FontSize = Int(Me.FontSize * (XScale + YScale) / 2)
    End With
    '移動並調整控制項大小
    For I = 0 To Me.Controls.Count - 1
        With Me.Controls(I)
            Select Case TypeName(Me.Controls(I))
                Case "Line"
                    .X1 = .X1 * XScale
                    .X2 = .X2 * XScale
                    .Y1 = .Y1 * YScale
                    .Y2 = .Y2 * YScale
                Case Else
                    .Move .Left * XScale, .Top * YScale, _
                    .Width * XScale, .Height * YScale
                    .FontSize = Int(.FontSize * (XScale + YScale) / 2)
            End Select
        End With
    Next
End Sub

回索引

Form 上的畫面(含 Control) 的輸出

'測試本範例至少要於 Form 上放置 Picture1 ，其他物件則隨意。
'本範例只及於表單的內含區，Title 及 Menu 不包括在內。
Option Explicit
'BitBlt API 函數有一個特性，它利用 DC 為標識，可以把一個物件的所有 Image
'(包括其所含內容物件之 Image )轉移到另一 DC 標識的物件上。不過此函數有兩要點
'一、單位為 Pixel ，所以截取範圍要經過 ScaleX,ScaleY 函數轉換。
'二、截取範圍超過來源 DC 標識物件，會把 Screen 的背景也抓進來，造成不相干圖
'像之截取，所以一定要準確算出截取範圍的大小。
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

'圖像截取之長度及寬度
Dim sx As Single, sy As Single
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    '按下 CTRL+ALT+S 則抓圖存檔
    If Shift = vbCtrlMask + vbAltMask And KeyCode = vbKeyS Then
        With Picture1
            .AutoRedraw = True
            BitBlt Picture1.hdc, 0, 0, sx, sy, Me.hdc, 0, 0, vbSrcCopy
            SavePicture .Image, App.Path & "\Test.bmp"
            .AutoRedraw = False
        End With
    End If
End Sub
Private Sub Form_Load()
    Me.KeyPreview = True
End Sub
Private Sub Form_Resize()
    '單位換算成 Pixel
    With Me
        sx = ScaleX(.ScaleWidth, Me.ScaleMode, vbPixels)
        sy = ScaleY(.ScaleHeight, Me.ScaleMode, vbPixels)
    End With

    '依 Form 大小調整 Picture1 大小
    With Picture1
        .Width = Me.ScaleWidth + .Width - .ScaleWidth
        .Height = Me.ScaleHeight + .Height - .ScaleHeight
        .Visible = False
    End With
End Sub

回索引

取代 Point & PSet 的 API 函數

孤星撰寫於文章

請問有沒有人知道, 有什麼API 涵數可取代VB內的繪圖方法PONIT和PSET，如果有是否能說明一下涵數內各引數的意義，謝謝。

老怪答：

Point API：
Declare Function GetPixel Lib "gdi32" Alias "GetPixel" (ByVal hdc As Long,
ByVal x As Long, ByVal y As Long) As Long
hdc:物件的 DC Handle
x:圖點 X 軸
y:圖點 Y 軸
如果你要取得某 PictureBox 某 x,y Pixel 之 ColorValue ，你可以這樣用：
Dim ColorLongValue As Long
ColorLongValue=GetPixel(Picture1.hdc,x,y)

PSet API：
Declare Function SetPixel Lib "gdi32" Alias "SetPixel" (ByVal hdc As Long,
ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
hdc:物件的 DC Handle
x:圖點 X 軸
y:圖點 Y 軸
crColor:設定指定 Pixel 的色彩值
如果你要設定某 PictureBox 某 x,y Pixel 之 ColorValue ，你可以這樣用：
SetPixel Picture1.hdc,x,y,RGB(r,g,b)

回索引

如何取得System Date Format

Stanley 撰寫於文章

如何在VB裡取得System Date Format.我想知道是dd/mm/yy或是mm/dd/yy.

老怪答：

Windows 控制台的[國別設定]功能掌管五項系統預設值：時區、數字、貨幣、時間、日期。
本範例用 GetSystemDefaultLCID API 取得國別設定代碼後，再用 GetLocaleInfo API 取得系統日期格式。
Code 範例：
Option Explicit
Private Const LOCALE_SLONGDATE = &H20   '長日期 LCType 代碼
Private Const LOCALE_SSHORTDATE = &H1F '短日期 LCType 代碼
'取得國別設定代碼 API ，不須傳送參數，以 Long 變數接傳回值即為代碼。
Private Declare Function GetSystemDefaultLCID Lib "kernel32" () As Long
'取得地區預設值，傳送參數如下：
'Locale:國別設定代碼
'LCType:國別設定各子項代碼
'lpLCData:國別設定子項之設定接收字串，是我們主要的目的
'cchData:接收字串傳回的長度
Private Declare Function GetLocaleInfo Lib "kernel32" Alias _
        "GetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, _
        ByVal lpLCData As String, ByVal cchData As Long) As Long
'長短日期儲存變數
Dim SDateString As String, LDateString As String
'國別設定代碼儲存變數
Dim LocalInfoID As Long
Private Sub Form_Click()
    Print "系統[長]日期格式：" & LDateString
    Print "系統[短]日期格式：" & SDateString
End Sub
Private Sub Form_Load()
Dim Check As Long
    '取得國別設定代碼
    LocalInfoID = GetSystemDefaultLCID()

    '預設接 256 位元
    SDateString = String(256, Chr(0))
    '取得短日期格式
    GetLocaleInfo LocalInfoID, LOCALE_SSHORTDATE, SDateString,
Len(SDateString)
    '切掉多餘部份
    SDateString = Left(SDateString, InStr(1, SDateString, Chr(0)) - 1)

    '取得長日期格式
    LDateString = String(256, Chr(0))
    GetLocaleInfo LocalInfoID, LOCALE_SLONGDATE, LDateString,
Len(LDateString)
    LDateString = Left(LDateString, InStr(1, LDateString, Chr(0)) - 1)
End Sub

回索引

如何判斷 Windows OS 版本

Guest 撰寫於文章

請問 win32 的 function 中有那個可以用來判斷作業系統為何?

老怪：

Option Explicit

Private Const VER_PLATFORM_WIN32_NT = 2
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VER_PLATFORM_WIN32s = 0

'此二常數為使用者自行宣告常數，因為 OSVERSIONINFO 的 dwPlatformId 變數在 95
和 98
'都是傳回 1，必須靠 dwMinorVersion 傳回值來輔助判別，OS 95 dwMinorVersion= 0
'OS 98 dwMinorVersion= 10
Private Const WIN32_WINDOWSEX_95 = 0
Private Const WIN32_WINDOWSEX_98 = 10

'VB API 檢視員中 GetVersionEx 函數 lpVersionInformation 參數前是有 Byval 傳
值
'設定的，但因在 VB 裏使用者自訂型態變數是無法用傳值傳到 API 裏，所以要銷去
'lpVersionInformation 前的 Byval 敘述，改用傳址遞送，才能正確。
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" _
        (lpVersionInformation As OSVERSIONINFO) As Long

Private Type OSVERSIONINFO
        dwOSVersionInfoSize As Long     '本資料結構大小
        dwMajorVersion As Long          '版本主編號
        dwMinorVersion As Long          '版本次編號
        dwBuildNumber As Long           '版本建立編號
        dwPlatformId As Long            '作業平台識別號
        szCSDVersion As String * 128    '版本進一步說明
End Type

Dim Ver As OSVERSIONINFO

Private Sub Form_Load()
Dim VerName As String
    Ver.dwOSVersionInfoSize = Len(Ver)
    GetVersionEx Ver

    Debug.Print "----Your Windows Version Info----"
    Debug.Print "版本主編號：" & Ver.dwMajorVersion
    Debug.Print "版本次編號：" & Ver.dwMinorVersion
    Debug.Print "版本建立編號：" & Ver.dwBuildNumber
    Debug.Print "作業平台識別號：" & Ver.dwPlatformId
    Debug.Print "版本進一步說明：" & Ver.szCSDVersion

    '執行判別 Windows Version 的自訂函數
    VerName = GotWinPlatFormName(Ver.dwPlatformId, Ver.dwMinorVersion)
    If VerName <> "" Then
        Debug.Print "--------" & VerName & "--------"
    Else
        Debug.Print "------無法判別的 Windows 版本------"
    End If
End Sub

'判別 Windows Version 的自訂函數
'參數 PlatFormId:OSVERSIONINFO 的 dwPlatformId 值
'參數 MinorVer:OSVERSIONINFO 的 dwMinorVersion 值
Private Function GotWinPlatFormName(ByVal PlatFormId As Long, _
        ByVal MinorVer As Long) As String
Dim ReturnString As String

    Select Case PlatFormId
        Case VER_PLATFORM_WIN32_NT
            ReturnString = "Windows NT"
        Case VER_PLATFORM_WIN32_WINDOWS
            Select Case MinorVer
                Case WIN32_WINDOWSEX_95
                    ReturnString = "Windows 95"
                Case WIN32_WINDOWSEX_98
                    ReturnString = "Windows 98"
            End Select
        Case VER_PLATFORM_WIN32s
            ReturnString = "Windows 32s"
    End Select

    GotWinPlatFormName = ReturnString
End Function

回索引

Wave 檔的播放

Declare Function sndPlaySound Lib "Winmm.dll" Alias "sndPlaySoundA" (ByVal SoundName As String, ByVal Flags As Long) As Long
- SoundName : 要播放的檔名
- Flags : 播放方式。
  為數值方式：
  - 0 = 播放完才往下 RUN
  - 1 = 邊放邊 RUN 程式
  - 2 = 若檔案不存在，將不發出警告訊息
  - 4 = 先將檔存於變數內，可避免延遲
  - 8 = 重覆播放 (須配合 1 !)
- 可合併使用，如 Flags = 1 + 8
- 呼叫範例：
  Call sndPlaySound(c:\wavs\3ucheng.wav, 1 + 8)
再來還有一個很重要的，就是關閉語音檔！
- 先宣告：
  Declare Function sndPlaySoundL Lib "WINMM" Alias "sndPlaySoundA" (ByVal NUL As Lnog, ByVal uFlags As Long) As Long
- Call sndPlaySoundL(0,0)
本篇來自三優資訊站：
     撰寫者：Cheng Tom 𩥉三優工作室𩻸 - 鄭郁霖
     E-Mail：chengtom@mail.tceb.edu.tw
     ＷＷＷ：http://miau.cs.ccu.edu.tw/3u/
     ＢＢＳ：𩥉三優資訊站𩻸 (04)246-3795 專業程式設計資源站

回索引

如何關掉ctrl+alt+del 按鍵功能

Declare Function SystemParametersInfo Lib "user32" Alias _
"SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, _
ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long

Public Const SPI_SCREENSAVERRUNNING = 97

' 關閉 Ctrl+Alt+Del 等所有功能鍵
summyI = SystemParametersInfo(SPI_SCREENSAVERRUNNING, True, "", 0)
' 解除
summyI = SystemParametersInfo(SPI_SCREENSAVERRUNNING, False, "", 0)

回索引

截取螢幕的程式

'執行本範例請於表單布置 Picture1,按下 CTRL+ALT+S 則抓圖存檔。
Option Explicit
'利用繪圖物件的 DC 做圖像移轉的函數
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
'取得繪圖物件 DC 的函數
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
'釋放繪圖物件 DC 的函數
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, _
        ByVal hdc As Long) As Long
'圖像截取之長度及寬度
Dim sx As Single, sy As Single
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Dim ScreenDC As Long
    '按下 CTRL+ALT+S 則抓圖存檔
    If Shift = vbCtrlMask + vbAltMask And KeyCode = vbKeyS Then
        '把表單關掉以截取視窗圖
        Me.Visible = False
        '強迫視窗關閉再進行下一步
        DoEvents
        '代碼 0 代表 Windows 的桌面畫面
        ScreenDC = GetDC(0)
        With Picture1
            .AutoRedraw = True
            BitBlt Picture1.hdc, 0, 0, sx, sy, ScreenDC, 0, 0, vbSrcCopy
            SavePicture .Image, App.Path & "\Test.bmp"
            .AutoRedraw = False
        End With
        '釋放 Windows 桌面畫面的 DC
        ReleaseDC 0, ScreenDC
        '回復表單為可見
        Me.Visible = True
    End If
End Sub
Private Sub Form_Load()
    Me.KeyPreview = True
    '單位換算成 Pixel
    With Screen
        sx = .Width / .TwipsPerPixelX
        sy = .Height / .TwipsPerPixelY
    End With
    '依 Form 大小調整 Picture1 大小
    With Picture1
        .Width = Screen.Width + .Width - .ScaleWidth
        .Height = Screen.Height + .Height - .ScaleHeight
        .Visible = False
    End With
End Sub

回索引

依副檔名開啟 Windows 登錄程式

'本範例功能在利用 Windows 系統登錄資料，找到副檔名預設關聯的執行程式，
'然後用 VB 的 Shell 方法啟動該程式。
'執行本範例請於 Form 上布置 Command1,CommonDialog1

Option Explicit
'預設登錄資料截取長度為 255
Private Const GET_REGDATA_LENGTH As Integer = 255
'以下 Windows 登錄資料主機碼(副檔名關聯設定)編號
Private Const HKEY_CLASSES_ROOT = &H80000000

'取得 Windows 登錄資料機碼之預設值函數
Private Declare Function RegQueryValue Lib "advapi32.dll" Alias _
        "RegQueryValueA" (ByVal hKey As Long, ByVal lpSubKey As String, _
        ByVal lpValue As String, lpcbValue As Long) As Long

'取得關聯程式 Open 命令的字串,ExString 為傳入之副檔名，記得前面須加 "." 符
號。
Private Function GetAppCommandString(ByVal ExString As String) As String
Dim ComString As String, RetString As String, ErrDescript As String
Dim RetCheck As Long
    '命令字串需有 "." 符號前導，並最少兩個字元。
    If Left(ExString, 1) <> "." Or Len(ExString) < 2 Then
        ErrDescript = "傳入之字串非有效之副檔名"
        GoTo ExecuteAppError
    End If

    '設定接收字串長度
    RetString = String(GET_REGDATA_LENGTH, Chr(0))
    '第一步先取出副檔名機碼的預設值字串，如 ".txt" 為 "txtfile"
    RetCheck = RegQueryValue(HKEY_CLASSES_ROOT, ExString, RetString, _
            GET_REGDATA_LENGTH)

    '如果找不到該副檔名登錄資料
    If RetCheck <> 0 Then
        ErrDescript = "[" & ExString & "]未於 Windows 登錄區設定有效之關聯程
式"
        GoTo ExecuteAppError
    End If

    '切掉接回字串多餘部份
    ComString = Left(RetString, InStr(RetString, Chr(0)) - 1)
    '第二步跟據副檔名機碼的預設值字串如 "txtfile",
    '找到 "txtfile\shell\open\command" 這個機碼
    ComString = ComString & "\shell\open\command"

    RetString = String(GET_REGDATA_LENGTH, Chr(0))
    '第三步跟據副檔名機碼的預設值字串如 "txtfile\shell\open\command" 這個機
碼,
    '取得值行程式路徑及啟動命令字串。
    RetCheck = RegQueryValue(HKEY_CLASSES_ROOT, ComString, RetString, _
            GET_REGDATA_LENGTH)

    If RetCheck <> 0 Then
        ErrDescript = "Windows 登錄區設定資料錯誤或毀損"
        GoTo ExecuteAppError
    End If

    ComString = Left(RetString, InStr(RetString, Chr(0)) - 1)

    '切掉檔案啟動命令之 "%1" 尾部參數
    ComString = CutEndChar(ComString)
    GetAppCommandString = ComString

    Exit Function

ExecuteAppError:
    MsgBox ErrDescript, vbOKOnly, "開啟 Windows 設定程式錯誤"
End Function

'取得檔案字串中的副檔名之自訂函數
Private Function GetExtenderFileName(ByVal FileString As String) As String
Dim I As Long, NoteNum As Long
    For I = 1 To Len(FileString)
        If Mid(FileString, I, 1) = "." Then
            NoteNum = I
        End If
    Next

    If NoteNum > 0 Then
        GetExtenderFileName = Right(FileString, Len(FileString) - NoteNum +
1)
    End If
End Function

'切掉檔案啟動命令之 "%1" 尾部參數之自訂函數
Private Function CutEndChar(ByVal SetString As String) As String
Dim I As Long, NoteNum As Long
    For I = 1 To Len(SetString)
        If Mid(SetString, I, 1) = " " Then
            NoteNum = I
        End If
    Next

    CutEndChar = Left(SetString, NoteNum)
End Function

Private Sub Command1_Click()
Dim SubString As String, cmdString As String
    With CommonDialog1
        .filename = ""
        .ShowOpen
        If CommonDialog1.filename <> "" Then
            SubString = GetExtenderFileName(CommonDialog1.filename)
            If SubString <> "" Then
                cmdString = GetAppCommandString(SubString)
                Shell cmdString & CommonDialog1.filename, vbNormalFocus
            Else
                MsgBox CommonDialog1.filename & " 無有效之副檔名", vbOKOnly,_
                        "檔案名稱錯誤"
            End If
        End If
    End With
End Sub

回索引

用 ToolBar 做 IE 浮動按鈕

AAAA.bbs

office 97中, 選單上的控制項本來是平面的, 因滑鼠移到它上面,而顯出有立體的感覺而浮起來,請問這些控制項在VB中是什麼控制項呀?該如何設定才有此結果?

藍色水瓶

請你照以下步驟作, 就可以使你的 Toolbar Control 有你要的 Style...

在你的 Project 裡加入一個 Code Module (Say Module1.Bas),裡面放上 :
=========== Module1.Bas ========================================
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal
HWnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As
Long) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA"
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2
As String) As Long
Const WM_USER = &H400
Const TB_SETSTYLE = WM_USER + 56
Const TB_GETSTYLE = WM_USER + 57
Const TBSTYLE_FLAT = &H800

Public Sub SetToolBarFlat(tlbTemp As Toolbar)
        Dim lngStyle As Long
        Dim lngResult As Long
        Dim lngHWND As Long

        lngHWND = FindWindowEx(tlbTemp.HWnd, 0&, "ToolbarWindow32",
vbNullString)
        lngStyle = SendMessage(lngHWND, TB_GETSTYLE, &O0, &O0)
        lngStyle = lngStyle Or TBSTYLE_FLAT
        lngResult = SendMessage(lngHWND, TB_SETSTYLE, 0, lngStyle)
        tlbTemp.Refresh

End Sub
在你的 Form (Say Form1.Frm) 上加上一個 Toolbar Control (Say Toolbar1, From Microsoft Common Controls 5.0/SP2, comctl32.ocx),再在 Form 的 Form_Load Event Handler 裡加入
=========== Form1.Frm ========================================
Private Sub Form_Load()
Call SetToolBarFlat(Toolbar1)
End Sub
這樣就可以了! Toolbar Control 似乎要裝過 MSIE3.0 以上才可以正常 Work, 這點不太確定, 提醒你一下...。

回索引

調整 PictureBox 大小配合 MCI 輸出

寄件者: MMX.bbs

MCI控制項讓它在picturebox上放出來時，picturebox的大小和avi的不合要怎麼解決呢?

老怪答：

Option Explicit
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" _
        (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, _
        ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Private Sub Command1_Click()
    '播放 AVI 檔案
    mciSendString "play MyAVI", vbNullString, 0, 0
End Sub

Private Sub Form_Load()
Dim mciString As String
Dim x As Long, y As Long

    '開啟 AVI 檔案
    mciString = "Open C:\temp\closeup.avi alias MyAVI parent " _
            & Picture1.hWnd & " style child"
    mciSendString mciString, vbNullString, 0, 0

    With Picture1
        x = ScaleX(.ScaleWidth, .ScaleMode, vbPixels)
        y = ScaleY(.ScaleHeight, .ScaleMode, vbPixels)
    End With

    '設定檔案播放區域
    mciString = "put MyAVI window at 0 0 " & x & " " & y
    mciSendString mciString, vbNullString, 0, 0
End Sub

Private Sub Form_Unload(Cancel As Integer)
    '關閉 AVI 檔案
    mciSendString "close MyAVI", vbNullString, 0, 0
End Sub

回索引

在 VB 中啟動 Internet Browser

寄件者: agajerry

請問在vb中可否能按一鈕就能連上ISP 謝謝

老怪答：

'測試本範例請於表單布置 Text1,Command1
Option Explicit
'預設登錄資料截取長度為 255
Private Const GET_REGDATA_LENGTH As Integer = 255
'以下 Windows 登錄資料主機碼(副檔名關聯設定)編號
Private Const HKEY_CLASSES_ROOT = &H80000000
'取得 Windows 登錄資料機碼之預設值函數
Private Declare Function RegQueryValue Lib "advapi32.dll" Alias _
        "RegQueryValueA" (ByVal hKey As Long, ByVal lpSubKey As String, _
        ByVal lpValue As String, lpcbValue As Long) As Long
Private Sub Command1_Click()
    Shell GetAppCommandString() & " " & Text1.Text, vbNormalFocus
End Sub
Private Sub Form_Load()
    Text1.Text = "www.microsoft.com.tw"
    Command1.Caption = "啟動 IE"
End Sub
'取得關聯程式 Open 命令的字串
Private Function GetAppCommandString() As String
Dim ComString As String, RetString As String, ErrDescript As String
Dim RetCheck As Long
    '設定接收字串長度
    RetString = String(GET_REGDATA_LENGTH, Chr(0))
    '跟據副檔名機碼的預設值字串如 "htmlfile",
    '找到 "text/html\shell\open\command" 這個機碼
    ComString = "htmlfile" & "\shell\open\command"
    '跟據副檔名機碼的預設值字串如 "htmlfile\shell\open\command" 這個機碼,
    '取得值行程式路徑及啟動命令字串。
    RetCheck = RegQueryValue(HKEY_CLASSES_ROOT, ComString, RetString, _
            GET_REGDATA_LENGTH)
    If RetCheck <> 0 Then
        ErrDescript = "Windows 登錄區設定資料錯誤或毀損"
        GoTo ExecuteAppError
    End If
    '切掉接回字串多餘部份
    ComString = Left(RetString, InStr(RetString, Chr(0)) - 1)
    '切掉檔案啟動命令之 "%1" 尾部參數
    ComString = CutEndChar(ComString)
    GetAppCommandString = ComString
    Exit Function
ExecuteAppError:
    MsgBox ErrDescript, vbOKOnly, "開啟 Windows 設定程式錯誤"
End Function
'切掉檔案啟動命令之 "%1" 尾部參數之自訂函數
Private Function CutEndChar(ByVal SetString As String) As String
Dim I As Long, NoteNum As Long
    For I = 1 To Len(SetString)
        If Mid(SetString, I, 1) = " " Then
            NoteNum = I
        End If
    Next
    CutEndChar = Left(SetString, NoteNum)
End Function

回索引

如何用VB建立捷徑(ShortCut)

Private Declare Function fCreateShellLink Lib "vb5stkit.dll" _
(ByVal Forder As String, ByVal ShortCutName As String, _
ByVal ExePath As String, ByVal Params As String) As Long

Dim ret As Long
'放在DeskTop
ret = fCreateShellLink("..\..\Desktop", "MyName", "c:\tools\spe3\pe2.exe", "")
'放在開始功能表
ret = fCreateShellLink("..", "MyName", "c:\tools\spe3\pe2.exe", "")
'放在程式集功能表
ret = fCreateShellLink(".", "MyName", "c:\tools\spe3\pe2.exe", "")

回索引

回首頁

分類

標題

大意

作者

日期