?? forok658.frm
字號:
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form Form1
Caption = "OKWAP OK676通訊錄處理程序"
ClientHeight = 6660
ClientLeft = 60
ClientTop = 450
ClientWidth = 9840
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 6660
ScaleWidth = 9840
StartUpPosition = 3 '窗口缺省
Begin VB.TextBox Text3
BeginProperty Font
Name = "宋體"
Size = 14.25
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 5055
Left = 2640
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 5
Top = 1560
Width = 7095
End
Begin VB.TextBox Text2
BeginProperty Font
Name = "宋體"
Size = 14.25
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 615
Left = 2640
TabIndex = 4
Top = 840
Width = 7095
End
Begin VB.TextBox Text1
BeginProperty Font
Name = "宋體"
Size = 14.25
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 615
Left = 2640
TabIndex = 2
Top = 120
Width = 7095
End
Begin VB.CommandButton Command1
Caption = "開 始 轉 換"
BeginProperty Font
Name = "宋體"
Size = 15
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 120
TabIndex = 0
Top = 1560
Width = 2415
End
Begin MSComDlg.CommonDialog ComDlg
Left = 3960
Top = 1680
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.Label Label3
BeginProperty Font
Name = "宋體"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 4455
Left = 0
TabIndex = 6
Top = 2160
Width = 2535
End
Begin VB.Label Label2
Caption = "手機目標文件夾"
BeginProperty Font
Name = "宋體"
Size = 15
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 120
TabIndex = 3
Top = 960
Width = 2535
End
Begin VB.Label Label1
Caption = "通訊錄文本文件"
BeginProperty Font
Name = "宋體"
Size = 15
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 120
TabIndex = 1
Top = 240
Width = 2655
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Type BrowseInfo
lngHwnd As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const MAX_PATH = 260
Private Declare Sub CoTaskMemFree Lib "ole32.dll" _
(ByVal hMem As Long)
Private Declare Function lstrcat Lib "Kernel32" _
Alias "lstrcatA" (ByVal lpString1 As String, _
ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" _
(lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" _
(ByVal pidList As Long, ByVal lpBuffer As String) As Long
Public Function BrowseForFolder(ByVal lngHwnd As Long, ByVal strPrompt As String) As String
On Error GoTo ehBrowseForFolder 'Trap for errors
Dim intNull As Integer
Dim lngIDList As Long, lngResult As Long
Dim strPath As String
Dim udtBI As BrowseInfo
'Set API properties (housed in a UDT)
With udtBI
.lngHwnd = lngHwnd
.lpszTitle = lstrcat(strPrompt, "")
.ulFlags = BIF_RETURNONLYFSDIRS
End With
'Display the browse folder...
lngIDList = SHBrowseForFolder(udtBI)
If lngIDList <> 0 Then
'Create string of nulls so it will fill in with the path
strPath = String(MAX_PATH, 0)
'Retrieves the path selected, places in the null
'character filled string
lngResult = SHGetPathFromIDList(lngIDList, strPath)
'Frees memory
Call CoTaskMemFree(lngIDList)
'Find the first instance of a null character,
'so we can get just the path
intNull = InStr(strPath, vbNullChar)
'Greater than 0 means the path exists...
If intNull > 0 Then
'Set the value
strPath = Left(strPath, intNull - 1)
End If
End If
'Return the path name
BrowseForFolder = strPath
Exit Function 'Abort
ehBrowseForFolder:
'Return no value
BrowseForFolder = Empty
End Function
Private Sub Command1_Click()
Dim one_line, name, phone_no, filename As String
Dim l, i As Integer
If Text2.Text <> "" And Text1.Text <> "" Then
Open Text1.Text For Input As #1
i = 0
Do While Not EOF(1)
Line Input #1, one_line
' MsgBox one_line
For l = 1 To Len(one_line)
If (Mid(one_line, l, 1) = Chr(9)) Then
name = Mid(one_line, 1, l - 1)
phone_no = Mid(one_line, l + 1)
'MsgBox phone_no
End If
Next l
'Text3.Text = Text3.Text & name & Chr(9) & phone_no & Chr(13) & Chr(10)
If i > 99 Then
filename = Text2.Text & "\phb0" & CStr(i) & ".vcf"
End If
If i < 100 Then
filename = Text2.Text & "\phb00" & CStr(i) & ".vcf"
End If
If i < 10 Then
filename = Text2.Text & "\phb000" & CStr(i) & ".vcf"
End If
Open filename For Output As #2
Print #2, "BEGIN:VCARD"
Print #2, "VERSION:2.1"
Print #2, "N;CHARSET=UTF-8;ENCODING=QUOTED-PRINTABLE:" & UTF8EncodeURI(name)
' Print #2, "FN;CHARSET=UTF-8:" & name
Print #2, "TEL;CELL;VOICE:" & phone_no
Print #2, "END:VCARD"
Close (2)
i = i + 1
Loop
Close (1)
'Command1.Caption = "處理完畢！"
MsgBox "處理完畢！"
End If
End Sub
Private Sub Form_Load()
Text1.Locked = True
Text2.Locked = True
Label3.Caption = "請按“通訊錄文本文件”選擇文本文件，請按手機目標文件夾選擇手機目標‘Contacts’文件夾。按開始轉換生成有關手機能導入的文件。通訊錄文本文件格式為姓名+TAB制表符+手機號換行。"
End Sub
Private Sub Label1_Click()
Dim one_line As String
Text3.Text = ""
ComDlg.CancelError = True
On Error GoTo Cancel
ComDlg.Flags = cdlOFNOverwritePrompt + cdlOFNPathMustExist + cdlOFNNoReadOnlyReturn
ComDlg.DialogTitle = "通訊錄文本文件"
ComDlg.Filter = "TextFiles(*.txt)|*.txt"
ComDlg.FilterIndex = 2
ComDlg.ShowOpen
Text1.Text = ComDlg.filename
Open Text1.Text For Input As 1
Do While Not EOF(1)
Line Input #1, one_line
' MsgBox one_line
Text3.Text = Text3.Text & one_line & Chr(13) & Chr(10)
Loop
Close (1)
Cancel:
End Sub
Private Sub Label2_Click()
Text2.Text = BrowseForFolder(Me.hWnd, "請選擇手機目標文件夾:")
End Sub
''''''''''''''''''''''''''''' 編碼代碼源于 因特網
Function UTF8EncodeURI(szInput)
Dim wch, uch, szRet
Dim x
Dim nAsc, nAsc2, nAsc3
If szInput = "" Then
UTF8EncodeURI = szInput
Exit Function
End If
For x = 1 To Len(szInput)
wch = Mid(szInput, x, 1)
nAsc = AscW(wch)
If nAsc < 0 Then nAsc = nAsc + 65536
If (nAsc And &HFF80) = 0 Then
szRet = szRet & wch
Else
If (nAsc And &HF000) = 0 Then
uch = "%" & Hex(((nAsc \ 2 ^ 6)) Or &HC0) & Hex(nAsc And &H3F Or &H80)
szRet = szRet & uch
Else
uch = "=" & Hex((nAsc \ 2 ^ 12) Or &HE0) & "=" & _
Hex((nAsc \ 2 ^ 6) And &H3F Or &H80) & "=" & _
Hex(nAsc And &H3F Or &H80)
szRet = szRet & uch
End If
End If
Next
UTF8EncodeURI = szRet
End Function
Function GBKEncodeURI(szInput)
Dim i As Long
Dim x() As Byte
Dim szRet As String
szRet = ""
x = StrConv(szInput, vbFromUnicode)
For i = LBound(x) To UBound(x)
szRet = szRet & "%" & Hex(x(i))
Next
GBKEncodeURI = szRet
End Function
''''''''''''''''''''''''''''' 編碼代碼源于 因特網
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -