你好，从网上找到发飞信的代码，在Excel中使用很好，拷到FT全局代码中总是出错，烦请版主给转换一下。
'//by:hyy514 qq:65921751
'//2012.10.26 Embed版
'//支持开源,使用此模块请保留作者注释
Option Explicit
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryW" (ByVal lpLibFileName As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function CallAsmCode Lib "user32" Alias "CallWindowProcW" (FirstAsmCode As Long, ByVal pA As Long, ByVal pB As Long, ByVal pC As Long, lpD As Long) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private AsmCode(94) As Long
Private pFull As String
Private pDll As Long
Private Fetion As Object
Private Const CODE = "&H476C6C44 &H6C437465 &H4F737361 &H63656A62 &H4C430074 &H46444953 &H536D6F72 &H6E697274 &H10067 &H0& &HC00000 &H0& &H6F4600 &H65006C &H320033 &H0& &H83EC8B55 &HE853D8C4 &H0& &H6CEB815B &H8D100010 &H105293 &H93FF5210 &H10001010 &H32938D50 &H52100010 &H1493FF50 &H8D100010 &H101C93 &HFF028910 &H101893 &H875FF10 &H101093FF &HC00B1000 &H86840F &H45890000 &H20938DFC &H52100010 &H1493FF50 &HB100010 &H506674C0 &H52EC558D &HFF0C75FF &H101C93 &H558D5810 &H938D52D8 &H10001042 &HEC558D52 &HBD0FF52 &H8D3E75C0 &HFF52DC55 &H93FF1075 &H1000101C &HD8558B50 &H8D54128B &H6A50DC45 &HD875FF00 &HB0C52FF &H8B1575C0 &H4D8BFC45 &H59018914 &H8BD18B51 &H52FF5112 &H14EB5804 &HEB06EB58 &HEB02EB0F &HFC75FF0B &H101893FF &HC0331000 &H10C2C95B &H6C6C4400 &H556E6143 &H616F6C6E &H776F4E64 &H0& &H53EC8B55 &HE8& &HEB815B00 &H10001155 &H1139938D &HFF521000 &H93FF0875 &H10001014 &H1374C00B &HC00BD0FF &H75FF0E74 &H1893FF08 &H33100010 &H4801EBC0 &H10C2C95B &H90909000"
Private Const CLSID = "{F1C654C6-4752-4B27-8C1E-E91DAD4D9ED0}"
Private Const IID = "{FF8C0A30-FC3C-4D87-82A8-B0C18314DC1A}"
Private Const FNAME = "Embed"
Private Function LoadObject(pDll As Long) As Object
Dim pObj As Long
Call InitAsmCode
pObj = CallAsmCode(AsmCode(20), StrPtr(GetF), StrPtr(CLSID), StrPtr(IID), pDll)
If pObj = 0 Then
MsgBox "无法加载"
End
End If
CopyMemory LoadObject, pObj&, 4&
End Function
Private Function UnLoadObject(pDll As Long) As Long
Call InitAsmCode
UnLoadObject = CallAsmCode(AsmCode(79), pDll, 0, 0, 0)
End Function
Private Sub InitAsmCode()
If AsmCode(4) Then Exit Sub
Dim pDll As Long
pDll = LoadLibrary(StrPtr("kernel32"))
AsmCode(0) = GetProcAddress(pDll, "LoadLibraryW")
AsmCode(1) = GetProcAddress(pDll, "GetProcAddress")
AsmCode(2) = GetProcAddress(pDll, "FreeLibrary")
Call FreeLibrary(pDll)
Dim i As Integer
Dim CodeAry() As String
CodeAry = Split(CODE)
For i = 4 To 94
AsmCode(i) = Val(CodeAry(i - 4))
Next
End Sub
Private Function mFull() As String
Dim sPtmp As String * 255
GetTempPath 255, sPtmp
mFull = Left(sPtmp, InStr(sPtmp, Chr(0)) - 1)
mFull = mFull & CLSID & ".6"
End Function
Private Function GetF() As String
If Len(pFull) Then
GetF = pFull
Else
pFull = mFull
If Len(Dir(pFull)) Then
GetF = pFull
Else
Dim hMem As Long
Dim nClipsize As Long
Dim lpData As Long
Dim bytData() As Byte
Sheet1.OLEObjects(FNAME).Copy
OpenClipboard 0&
hMem = GetClipboardData(49156)
If CBool(hMem) Then
nClipsize = GlobalSize(hMem)
lpData = GlobalLock(hMem)
If lpData <> 0 Then
ReDim bytData(0 To nClipsize - 1) As Byte
CopyMemory bytData(0), ByVal lpData, nClipsize
End If
GlobalUnlock hMem
End If
EmptyClipboard
CloseClipboard
Dim iPos As Long
Dim iCountZero As Integer
Dim lOffset As Long
Dim lFilesize As Long
For iPos = 0 To nClipsize
If bytData(iPos) = 0 Then
iCountZero = iCountZero + 1
If iCountZero = 3 Then Exit For
End If
Next
iPos = iPos + 5
CopyMemory lOffset, bytData(iPos), 4
iPos = iPos + lOffset + 4
CopyMemory lFilesize, bytData(iPos), 4
iPos = iPos + 4
CopyMemory bytData(0), bytData(iPos), lFilesize
ReDim Preserve bytData(0 To lFilesize) As Byte
Dim fNumber As Integer
fNumber = FreeFile
Open pFull For Binary As #fNumber
Put #fNumber, , bytData
Close #fNumber
GetF = pFull
End If
End If
End Function
Private Sub Class_Initialize()
Set Fetion = LoadObject(pDll)
End Sub
Private Sub Class_Terminate()
Debug.Print Logout
Set Fetion = Nothing
UnLoadObject pDll
End Sub
Public Function Init(ByVal sUr As String, ByVal sPw As String) As Boolean
Init = Fetion.Login(sUr, sPw)
End Function
Public Function Logout() As Boolean
On Error Resume Next
Logout = Fetion.Logout
End Function
Public Function SendMsgMyself(ByVal sContent As String, Optional sTime As String = vbNullString) As String
If sTime = vbNullString Then
SendMsgMyself = Fetion.SendMsgMyself(sContent)
Else
SendMsgMyself = Fetion.SendMsgMyself(sContent, sTime)
End If
End Function
Public Function SendMsgFnd(ByVal sContent As String, ByVal sMobileNumber As String) As String
SendMsgFnd = Fetion.SendMsgFnd(sContent, sMobileNumber)
End Function
Public Function AddFnd(ByVal sNickname As String, ByVal sMobileNumber As String) As String
AddFnd = Fetion.AddFnd(sNickname, sMobileNumber)
End Function
加好友 
发短信
Post By：2015/2/27 10:03:00 [只看该作者]
