用VBA呼叫API 切換輸入法(IME)

用VBA呼叫API 切換輸入法(IME):

Private Declare Function GetKeyboardLayoutList Lib "user32" (ByVal nBuff As Long, lpList As Long) As Long
Private Declare Function ActivateKeyboardLayout Lib "user32" (ByVal hkl As Long, ByVal flags As Long) As Long
Private Declare Function GetKeyboardLayoutName Lib "user32" Alias "GetKeyboardLayoutNameA" (ByVal pwszKLID As String) As Long
Private Declare Function ImmGetDescription Lib "imm32.dll" Alias "ImmGetDescriptionA" (ByVal hkl As Long, ByVal lpsz As String, ByVal uBufLen As Long) As Long
'取得某個中文輸入法的Keyboard Handle ImeNmae傳入"大易" "注音" 等
'傳回0表示沒有找到
Public Function GetIMEKeyBoardHandle(ByVal ImeName As String) As Long
Dim hkb5(24) As Long, i As Long
Dim kln As String
Dim BuffLen As Long
Dim Buff As String
Dim RetStr As String, res As Long
Dim RetCount As Long, LayOutNo As Long

Buff = String(255, 0)
BuffLen = 255
kln = String(8, 0)
LayOutNo = GetKeyboardLayoutList(25, hkb5(0))
GetIMEKeyBoardHandle = 0
For i = 0 To LayOutNo - 1
ActivateKeyboardLayout hkb5(i), 0
res = GetKeyboardLayoutName(kln)
RetCount = ImmGetDescription(hkb5(i), Buff, BuffLen)
RetStr = Left(Buff, RetCount)
If InStr(1, RetStr, ImeName) <> 0 Then
GetIMEKeyBoardHandle = hkb5(i)
Exit Function
End If
Next i
End Function

'設定某個中文輸入法
Public Function ActiveIMEKeyBoard(ByVal ImeName As String) As Boolean
Dim hkbd As Long, i As Long
ActiveIMEKeyBoard = True
hkbd = GetIMEKeyBoardHandle(ImeName)
If hkbd <> 0 Then
i = ActivateKeyboardLayout(hkbd, 0)
If i <> 0 Then
ActiveIMEKeyBoard = True
End If
End If
End Function

Sub ChangeIMEToE()
Call ActiveIMEKeyBoard("English (American)")
End Sub

Sub ChangeIMEToC()
Call ActiveIMEKeyBoard("注音")
End Sub

用VBA列出檔案所有資訊

以下VBA會列出所有檔案資訊

(不論是否該檔有沒有開啟,都可以得到正確檔案資訊)

Sub getDetailsOfFile()
Dim myShl As New Shell
Dim curFolder As Folder
Dim theItm As FolderItem
Dim Fn As Variant
Dim theTitle As String
Dim outStr As String
Dim i As Long
Fn = Application.GetOpenFilename
If Fn = "False" Then Exit Sub
Set curFolder = myShl.Namespace(CurDir)
Fn = Split(Fn, "\"): Fn = Fn(UBound(Fn))
With curFolder
theTitle = .GetDetailsOf(0, i)
Do While theTitle <> ""
outStr = outStr & theTitle & ": " & vbTab & .GetDetailsOf(.Items.Item(Fn), i) & vbCrLf
Debug.Print i & .GetDetailsOf(.Items.Item(Fn), i)
i = i + 1
theTitle = .GetDetailsOf(0, i)
Loop
End With
Set myShl = Nothing
MsgBox outStr
End Sub

請設定引用項目Microsoft Shell Controls and Automation
VBE=>工具=>設定引用項目=>勾選Microsoft Shell Controls and Automation

如何將Excel永遠顯示在最上層?

用 API SetWindowPos~

Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, y, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const TOPMOST_FLAGS = SWP_NOMOVE Or SWP_NOSIZE

Public Sub MakeNormal(hwnd As Long)
SetWindowPos hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS
End Sub

Public Sub MakeTopMost(hwnd As Long)
SetWindowPos hwnd, HWND_TOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS
End Sub

Sub OnTop()
Call MakeTopMost(Application.hwnd)
End Sub

Sub OnNor()
Call MakeNormal(Application.hwnd)
End Sub

Sub auto_open()
Application.OnKey key:="{F1}", procedure:="OnTop"
Application.OnKey key:="{F2}", procedure:="OnNor"
End Sub

Google AdSense 是真的~ 我收到Google從美國寄來的確認函了~

這是真的耶~
前幾天收到Google從美國寄來給我的信了,真是感動!!
(會先收到Email通知,然後過幾個星期就會收到信了喔!!)


==== 以下是Email通知 ====
您好：我們最近透過標準郵件遞送方式，寄給了您一組「個人識別號碼」(PIN)。 您應該會在 2 至 4 週之內收到此號碼。 一旦您收到 PIN 後，就必須將它輸入帳戶中，才能符合收取 AdSense 款項的資格。 若要輸入您的 PIN，只要按照 PIN 郵件中所附的指示進行即可。請注意，出版者自原始發行日期起有 6 個月的時間可以輸入其 PIN。 如果您未在 4 個月內輸入 PIN，我們就會開始在您的網頁上放送「公益廣告」(PSA)。 如果您未在 6 個月內輸入 PIN，您的帳戶將會被停用，而且任何未支付的收益款項將會退回給適當的廣告客戶。 您可以前往http://www.google.com/adsense_pin_info 瞭解更多關於我們 PIN 政策的資訊。如有其他關於取得款項的問題，請造訪http://www.google.com/adsense_payment_guide 。 . 如果您想要檢視此資訊的影音模式，我們建議您參閱位在http://www.google.com/adsense_payment_demo 的付款示範模式 (目前只提供英文版)。
Google AdSense 小組敬上

==== 以下是平信通知 ====
封面1

封面2

內頁

加速VBA的方法:

加速VBA的方法:

1.關閉螢幕更新 : Application.ScreenUpdating = False 'True
2.禁止觸發事件 : Application.EnableEvents = False 'True
3.禁止交互模式 : Application.Interactive = False 'True
4.計算模式設定為手動 : Application.Calculation = xlCalculationManual 'xlCalculationAutomatic
5.儲存格寫法 : 請使用cells : cells(1,1).value > cells(1,1) > Range("A1") > [A1]
6.比較句 :
IF A THEN
IF B THEN
優於
IF A AND B THEN 與
IF A THEN
... ELSE IF B THEN
優於
IF A OR B then
7.IF 快於SELECT
8.IF/ELSE 快於 IIF
9.循環句
For 語句快於DO/WHILE
For/each快於for/to

10.使用With語句
11.盡量不用Variant類型
12.使用Option Explicit
13.給返回值一個明確的類型.
14使用left$,而不用left,使用int%,而不用int

15.set=nothing
16.有些工作表函數（方法）速度是很快的,比如FIND,VLOOKUP等,要記得使用它們,不要花力氣去做不討好的事。
17.當使用工作表函數時,操作對象應避免使用內存變量,那樣反而慢。

18.使用不相鄰的range前,先使用UNION,一次進行.

使用內存數組
1．內存變量的運算速度大大快於RANGE對象。
將RANGE數據寫入內存數組。
下面兩句將生成一個65536行,6列的數組。
用這種方法產生的數組都是兩維數組,即使引用的RANGE只有一行或一列。
下標始於1,不受option base設定的影響。
arr必需聲明為Variant類型。
Dim arr()
arr=range(“A1:F65536”)
將內存數組數據寫入RANGE。
在內存數組經過計算處理後,寫回時只需下句就可以了。
range(“A1:F65536”)= arr
2．非數組變量快於數組變量。
當數組很大時,根據下標提取數值會比從單個變量慢得多,這時可以把需要多
次使用的數組值先賦給內存變量。
3．減少使用REDIM的次數。
REDIM是對數組操作中最費時的動作。
可以先預算大小,不夠或多餘時再進行調整。

移除VBA.xls.xla 密碼 保護

移除VBA.xls.xla 密碼 保護

'移除VBA编码保护
Sub MoveProtect()
Dim FileName As String
FileName = Application.GetOpenFilename("Excel文件（*.xls & *.xla）,*.xls;*.xla", , "VBA破解")
If FileName = CStr(False) Then
Exit Sub
Else
VBAPassword FileName, False
End If
End Sub

'设置VBA编码保护
Sub SetProtect()
Dim FileName As String
FileName = Application.GetOpenFilename("Excel文件（*.xls & *.xla）,*.xls;*.xla", , "VBA破解")
If FileName = CStr(False) Then
Exit Sub
Else
VBAPassword FileName, True
End If
End Sub

Private Function VBAPassword(FileName As String, Optional Protect As Boolean = False)
If Dir(FileName) = "" Then
Exit Function
Else
FileCopy FileName, FileName & ".bak"
End If

Dim GetData As String * 5
Open FileName For Binary As #1
Dim CMGs As Long
Dim DPBo As Long
For i = 1 To LOF(1)
Get #1, i, GetData
If GetData = "CMG=""" Then CMGs = i
If GetData = "[Host" Then DPBo = i - 2: Exit For
Next

If CMGs = 0 Then
MsgBox "请先对VBA编码设置一个保护密码...", 32, "提示"
Exit Function
End If

If Protect = False Then
Dim St As String * 2
Dim s20 As String * 1

'取得一个0D0A十六进制字串
Get #1, CMGs - 2, St

'取得一个20十六制字串
Get #1, DPBo + 16, s20

'替换加密部份机码
For i = CMGs To DPBo Step 2
Put #1, i, St
Next

'加入不配对符号
If (DPBo - CMGs) Mod 2 <> 0 Then
Put #1, DPBo + 1, s20
End If
MsgBox "文件解密成功......", 32, "提示"
Else
Dim MMs As String * 5
MMs = "DPB="""
Put #1, CMGs, MMs
MsgBox "对文件特殊加密成功......", 32, "提示"
End If
Close #1
End Function

如何把yahoo奇摩拍賣的評價匯入EXCEL,使用巨集或VBA

如何把yahoo奇摩拍賣的評價匯入EXCEL,使用巨集或VBA

• 以下VBA執行前,請將UserID填入自己的Yahoo拍賣ID喔,並請登入yahoo拍賣.
• 將以下VBA原封不動copy的module1下即可.
• 沒有寫的很完整,想要防呆或增加功能,就自己試試囉~
• 若要捉別人的,程式只要做小修改即可......

Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Sub GetYahooEva()
UserID = "xxxxxx" '請填入自己的帳號
HtmlFile = "C:\JackyLu.txt"
TargetUser = "http://tw.user.bid.yahoo.com/tw/show/rating?userID=" & UserID
DownloadFile CStr(TargetUser), CStr(HtmlFile)

AllData = UTF8ToBig5(HtmlFile)
TargetDataStart = "共 "
TargetDataStartLen = Len(TargetDataStart)
TargetDataStartPosition = InStr(AllData, TargetDataStart)

TargetDataStop = "<"
TargetDataStopLen = Len(TargetDataStop)
TargetDataStopPosition = InStr(TargetDataStartPosition + TargetDataStartLen, AllData, TargetDataStop)
SheetCnt = Mid(AllData, TargetDataStartPosition + TargetDataStartLen, TargetDataStopPosition - TargetDataStartPosition - TargetDataStartLen)
Workbooks.Add
Sheet1.Name = Format(Date, "yyyymmdd") & Format(Time, "hhmmss")
For SHN = 1 To SheetCnt
TargetUser = "http://tw.user.bid.yahoo.com/tw/show/rating?userID=" & UserID & "&pageNo=" & SHN
DownloadFile CStr(TargetUser), CStr(HtmlFile)
AllData = UTF8ToBig5(HtmlFile)
AllData = ReplaceUnnecessary(AllData)
AllData = TrimAllBlank(AllData)
Do
TargetDataStart = "評價為："
TargetDataStartLen = Len(TargetDataStart)
TargetDataStartPosition = InStr(AllData, TargetDataStart)
TargetDataStop = "[回應]"
TargetDataStopLen = Len(TargetDataStop)
TargetDataStopPosition = InStr(TargetDataStartPosition + TargetDataStartLen, AllData, TargetDataStop)

If TargetDataStartPosition <> 0 Then
T = Mid(AllData, TargetDataStartPosition, TargetDataStopPosition - TargetDataStartPosition)
NL1 = "買家滿意度"
NL2 = "意見︰"
NL3 = "回覆︰"
T = Replace(T, NL1, Chr(10) & NL1)
T = Replace(T, NL2, Chr(10) & NL2)
T = Replace(T, NL3, Chr(10) & NL3)
x = x + 1
Cells(x, 1).FormulaR1C1 = T
AllData = Mid(AllData, TargetDataStopPosition)
Else
Exit Do
End If
Loop
Next
Columns("A:A").ColumnWidth = 200
Cells.EntireRow.AutoFit
ActiveWindow.Zoom = 75
End Sub

Function UTF8ToBig5(HtmlFile)
Dim objStream As Object
Set objStream = CreateObject("ADODB.Stream")
With objStream
.Type = 2
.Mode = 3
.Open
.Charset = "Big5" 'utf-8 Big5 或其他編碼
.LoadFromFile HtmlFile
UTF8ToBig5 = .ReadText
.Close
End With
End Function

Function TrimAllBlank(TrimB)
TrimB = Replace(TrimB, " ", "")
If InStr(TrimB, " ") > 0 Then
TrimB = TrimAllBlank(TrimB)
End If
TrimAllBlank = TrimB
End Function

Function ReplaceUnnecessary(RUString)
RUString = Replace(RUString, Chr(9), "")
RUString = Replace(RUString, Chr(13), "")
RUString = Replace(RUString, Chr(10), "")
RUString = Replace(RUString, " ", "")
Do
LI = InStr(RUString, "<") If LI = 0 Then Exit Do RI = InStr(LI, RUString, ">")
RUString = Replace(RUString, Mid(RUString, LI, RI - LI + 1), "")
Loop
ReplaceUnnecessary = RUString
End Function

Public Function DownloadFile(URL As String, LocalFilename As String) As Boolean
Dim lngRetVal As Long
lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0)
If lngRetVal = 0 Then DownloadFile = True
End Function