我的VBA自定义函数研习收获

weiyingde

接上，继续。。。。。。
Public Function GetFrBY(tmpWord As String, Nuber As Integer)
    '必应,用时2分25秒,较慢。
    'http://cn.bing.com/dict/search?q=about+to&go=%E6%8F%90%E4%BA%A4&qs=bs&form=CM
    'http://cn.bing.com/dict/search?q=about+to&go=提交&qs=bs&form=CM
    Dim XH As Object
    Dim s() As String
    Dim str_tmp As String, url
    Dim str_base As String
    If Len(tmpWord) = 0 Then Exit Function
    tmpTrans = "": tmpPhonetic = ""
    tmpWord = Replace(tmpWord, " ", "+")
'URL = "http://cn.bing.com/dict/search?q=" & tmpWord & "&go=%E6%8F%90%E4%BA%A4&qs=bs&form=CM"
    url = "http://cn.bing.com/dict/search?q=" & tmpWord
    Set XH = CreateObject("Msxml2.XMLHTTP") 'Microsoft.XMLHTTP")
On Error Resume Next
    XH.Open "GET", url, 0 'True
    XH.send '(Null)
     While XH.readyState <> 4
         DoEvents
     Wend
     str_base = XH.responseText
    ' XH.Close
     Set XH = Nothing
     '取得音标部分
     yb = Split(Split(str_base, "<div class=""hd_prUS"">")(1), "<span class=""pos"">")(0)
     '取得中文含义部分
     hy = Split(str_base, "<div class=""hd_div1"">")(0)
     '对音标部分进行分解，分别取得英国和美国音标
     yb = Split(yb, "<div class=""hd_pr"">")
     ybUS = Split(Split(str_base, "美[")(1), "，")(0)
     ybEN = Split(Split(str_base, "英[")(1), "，")(0)
     tmpPhonetic = "美 [" & ybUS & " 英 [" & ybEN
     '对中文含义分解
     hy = Split(hy, "<span class=""pos"">")
     hytmp = ""
     For i = LBound(hy) + 1 To UBound(hy)
         hytmp = hytmp & DelHtml(Split(hy(i), "</span></span>")(0)) & vbCrLf
     Next i
     If UBound(hy) = 0 Then hytmp = ""
     tmpTrans = Left(hytmp, Len(hytmp) - 1) '
' tmpTrans = Replace(Split(Split(str_base, "]，")(2), " 网络释义：")(0), "； ", Chr(10))
    Select Case Nuber
           Case 1: GetFrBY = tmpTrans '获取中文词
           Case 2: GetFrBY = tmpPhonetic '获取英文的音标
           Case 3: GetFrBY = tmpTrans & vbCr & tmpPhonetic
    End Select
End Function

Public Function 必应抓汉词(isr, Nub)
'isr 为英文单词，相当于专业情况下英译汉词典，
'为英语老师制作英译汉单词表省心，只可惜其抓音标的能力名存实亡。
'盼望网络高人完善之。
Dim html As New HTMLDocument, i, url
On Error Resume Next
   With CreateObject("Microsoft.XMLHTTP")
        url = "http://cn.bing.com/dict/search?q=" & isr
        .Open "get", url, True
        .send
       If .Status = 200 Then
            While .readyState <> 4
                DoEvents
            Wend
            html.body.innerHTML = .responseText
            If Nub = 1 Then
               必应抓汉词 = html.getElementsByClassName("hd_p1_1")(0).innerText '抓音表
            ElseIf Nub = 2 Then
               必应抓汉词 = html.getElementsByTagName("ul")(1).innerText '抓中文翻译
            End If
       Else
               必应抓汉词 = "无网络"
       End If
   End With
End Function

Function GetURL$(txt$)
'备用函数1
'作为英汉词通函数的子函数
'Dim a() As Byte
'a = StrConv(txt, vbFromUnicode, &H804)
    For i = 1 To Len(txt)
        txt1 = Mid(txt, i, 1)
        If Abs(Asc(txt1)) < 128 Then
            GetURL = GetURL & txt1
        Else
            GetURL1 = Application.Hex2Bin(Left(Hex(AscW(txt1)), 2), 8)
            GetURL1 = GetURL1 & Application.Hex2Bin(Right(Hex(AscW(txt1)), 2), 8)
            GetURL1 = Application.Replace(Application.Replace(GetURL1, 11, , 10), 5, , 10)
            GetURL2 = "%E" & Application.Bin2Hex(Left(GetURL1, 4))
            GetURL2 = GetURL2 & "%" & Application.Bin2Hex(Mid$(GetURL1, 5, 8))
            GetURL2 = GetURL2 & "%" & Application.Bin2Hex(Mid$(GetURL1, 13, 8))
            GetURL = GetURL & GetURL2
        End If
    Next
'如果一律转码是: GetURL = GetURL & "%" & Right("0" & Hex(a(i)), 2)
End Function
Function DelHtml(strh) '正则提取字符串
'备用函数2
'作为字母函数名的诸多函数的子函数
    Dim A As String
    Dim RegEx As Object
    'Dim mMatch As Match
    'Dim Matches As matchcollectio
    A = strh
    A = Replace(A, Chr(13) & Chr(10), "")
'    A = Replace(A, Chr(32), "")
    A = Replace(A, Chr(9), "")
    A = Replace(A, "</p>", vbCrLf)   '给段落后加上回车
    Set RegEx = CreateObject("vbscript.regexp")    '引入正则表达式
    With RegEx
        .Global = True
        .Pattern = "\<[^<>]*?\>"   '用<>括起来的html符号
        .MultiLine = True  '多行有效
        .ignorecase = True  '忽略大小写(网页处理时这个参数比较重要)
        A = .Replace(A, "")   '将html符号全部替换为空
    End With
    A = Trim(A)
   
    '特殊符号处理
    A = Replace(A, "&lt;", "<")
    A = Replace(A, "&gt;", ">")
    A = Replace(A, "&amp;", "&")
    A = Replace(A, "&quot;", "\")
    A = Replace(A, "&-->", vbCrLf)
    A = Replace(A, "&#230;", ChrW(230)) '&#230;
    A = Replace(A, "&#160;", ChrW(160)) '&#160;
    A = Replace(A, "&nbsp;", " ")  '&nbsp;?
    DelHtml = A
End Function

weiyingde

获取媒体时长。
'Public arr(), n
Public Sub 随机(mypth As String)
Dim arr()
Erase arr:    n = 0
Call Getfd(mypth, arr, n)
Randomize
sj = Int(Rnd * UBound(arr))
ipath = arr(sj + 1)
Set Obj = CreateObject("Shell.Application")
Set fd = Obj.Namespace(ipath)
For Each f In fd.items
    If InStr(LCase(f.Name), "mp") > 0 Then
        shj = fd.GetDetailsOf(f, 27)
        If Len(shj) <> 0 Then
           m = m + 1
           Sheet1.Cells(1, 1) = ipath
           Sheet1.Cells(m + 1, 1) = f
           Sheet1.Cells(m + 1, 2) = shj
           mint = Val(Split(shj, ":")(1))
           scnd = Val(Split(shj, ":")(2))
           Sheet1.Cells(m + 1, 3) = mint * 60 + scnd
       End If
     End If
Next
End Sub
Sub Getfd(ByVal pth, arr, n) '自带参数和Public arr(), n是一样的，不过后两个参数，在程序运行过程中，自动生成
    Set Fso = CreateObject("scripting.filesystemobject")
    Set ff = Fso.getfolder(pth)
           If InStr(pth, "音") > 0 Then
              n = n + 1
              ReDim Preserve arr(1 To n)
              arr(n) = pth
           End If
    For Each fd In ff.subfolders
        Call Getfd(fd, arr, n)
    Next fd
End Sub
Sub 填充()
On Error Resume Next
Dim mypth As String
ActiveSheet.UsedRange.ClearContents
Cells(1, 1) = "文件夹名"
随机 ("F:\音视频\汽车音乐")
End Sub

weiyingde

Public Sub 自定义页面(Paper As String, Bsh As String, TxtColm As Integer, Optional Wdh As Single, Optional Hgt As Single)
    On Error Resume Next
    Select Case Paper
           Case "A4"
                 wd = IIf(Bsh = "hb", 297, 210)
                 ht = IIf(Bsh = "hb", 210, 297)
                 lk = IIf(Bsh = "hb", 265, 178)
           Case "16K"
                 wd = IIf(Bsh = "hb", 260, 184)
                 ht = IIf(Bsh = "hb", 184, 260)
                 lk = IIf(Bsh = "hb", 228, 152)
           Case "zdy"
                 wd = IIf(Bsh = "hb", Hgt, Wdh)
                 ht = IIf(Bsh = "hb", Wdh, Hgt)
                 lk = IIf(Bsh = "hb", Hgt - 32, Wdh - 32)
    End Select
    With ActiveDocument.PageSetup
        .Orientation = IIf(Bsh = "hb", wdOrientLandscape, wdOrientPortrait)
        .PageWidth = MillimetersToPoints(wd)
        .PageHeight = MillimetersToPoints(ht)
        .TopMargin = MillimetersToPoints(12)
        .BottomMargin = MillimetersToPoints(12)
        .LeftMargin = MillimetersToPoints(16)
        .RightMargin = MillimetersToPoints(16)
        .HeaderDistance = MillimetersToPoints(12.5)
        .FooterDistance = MillimetersToPoints(12.5)
        .Gutter = MillimetersToPoints(0)
        .LayoutMode = wdLayoutModeDefault '版式模式为无网络，作用：紧缩行距
        With .TextColumns
             .SetCount NumColumns:=TxtColm
             .EvenlySpaced = True
             .LineBetween = False
            If TxtColm <> 1 Then .Width = MillimetersToPoints(lk)
        End With
    End With
End Sub

weiyingde

一个非常好的自定义函数，由yjh_27大侠提供，见http://club.excelhome.net/forum. ... ;page=2#pid10249347 12楼
Function a2cc(s, Optional m = 0)
If s < 0 Then
t = "负"
s = -s
Else
t = ""
End If

yfl = Split(s, ".")
If m = 0 Then
    tm = Split("零 壹 贰 叁 肆 伍 陆 柒 捌 玖")
Else
    tm = Split("〇 一 二 三 四 五 六 七 八 九")
End If
If m = 0 Then
    tk = Split("亿 万 仟 佰 拾")
Else
    tk = Split("亿 万 千 百 十")
End If

L = Len(yfl(0)) - 1
t0 = 0.1
yi = L \ 8
ReDim y(yi)
For i = 0 To yi
    y(i) = Right(yfl(0), 8)
    If Len(yfl(0)) > 8 Then yfl(0) = Left(yfl(0), Len(yfl(0)) - 8)
Next

For i = yi To 0 Step -1
    LW = Len(y(i)) - 1
    wi = LW \ 4
    ReDim w(wi)
    For ii = 0 To wi
        w(ii) = Right(y(i), 4)
        If Len(y(i)) > 4 Then y(i) = Left(y(i), Len(y(i)) - 4)
    Next
    For ii = wi To 0 Step -1
        L = Len(w(ii))
        For iii = 1 To L
            t1 = Mid(w(ii), iii, 1)
            If t0 > 0 Or t1 > 0 Then
            t = t & tm(t1)
            L1 = L + 1 - iii
            If t1 > 0 Then
                If L1 = 4 Then
                    t = t & tk(2)
                ElseIf L1 = 3 Then
                     t = t & tk(3)
                ElseIf L1 = 2 Then
                    t = t & tk(4)
                End If
            End If
            
            t0 = t1
            End If
        Next
        
        If ii > 0 Then
            If t0 = 0 Then
                t = Mid(t, 1, Len(t) - 1) & tk(1) & tm(0)
            Else
                t = t & tk(1)
            End If
        End If
    Next
    If i > 0 Then
        If t0 = 0 Then
            t = Mid(t, 1, Len(t) - 1) & tk(0) & tm(0)
        Else
            t = t & tk(0)
        End If
    End If
Next


If UBound(yfl) > 0 Then
    If t = "" Then
        t = tm(0) & "点"
    ElseIf Right(t, 1) = tm(0) Then
        Mid(t, Len(t), 1) = "点"
    Else
        t = t & "点"
    End If
    L = Len(yfl(1))
    For i = 1 To L
        t = t & tm(Mid(yfl(1), i, 1))
    Next
End If

a2cc = t
End Function

weiyingde

又一个非常好的自定义函数，由mzbao大侠提供，见http://club.excelhome.net/forum. ... ;page=2#pid10249347 13楼
Function NumToCN(ByVal ArabicNum) As String
    If Not IsNumeric(ArabicNum) Then
        If Trim(ArabicNum) <> "" Then NumToCN = "N/A" Else NumToCN = ""
        Exit Function
    End If
   
    Dim strInt&, strDec$, i%, strNumCN$, strTempCN$, strMinus$
   
    strNumCN = "〇一二三四五六七八九"
   
    If ArabicNum < 0 Then strMinus = "负"
    If InStr(ArabicNum, ".") Then strDec = Split(ArabicNum, ".")(1)
    ArabicNum = Int(Abs(ArabicNum))
    strTempCN = Format(ArabicNum, "0千0百0十0兆0千0百0十0亿0千0百0十0万0千0百0十0")
    For i = 1 To 3: strTempCN = Replace(strTempCN, 0 & Mid("千百十", i, 1), 0): Next
    For i = 1 To 3: strTempCN = Replace(strTempCN, "0000" & Mid("兆亿万", i, 1), ""): Next
    For i = 1 To 3: strTempCN = Replace(strTempCN, "00", 0): Next
    For i = 1 To 3: strTempCN = Replace(strTempCN, "0" & Mid("兆亿万", i, 1), Mid("兆亿万", i, 1)): Next
    If ArabicNum = 0 Then strTempCN = "〇"
    If Left(strTempCN, 1) = 0 Then strTempCN = Mid(strTempCN, 2)
    If Right(strTempCN, 1) = 0 Then strTempCN = Left(strTempCN, Len(strTempCN) - 1)

    If Len(strDec) Then strTempCN = strTempCN & "点" & strDec
    For i = 0 To 9: strTempCN = Replace(strTempCN, i, Mid(strNumCN, i + 1, 1)): Next
   
    NumToCN = strMinus & strTempCN
End Function

weiyingde

求指定上限和下限的多个随机数。
Public Function 随机数(LB As Integer, UB As Integer, Nb As Integer)
Dim x%, y%, t%, i%, arr()
x = UB - LB + 1
y = LB - 1
ReDim A(x)
    Do
        t = Int(x * Rnd + 1)
        If A(t) = 0 Then
            i = i + 1
            A(t) = t
            ReDim Preserve arr(1 To i)
            arr(i) = t + y
        End If
    Loop Until i = Nb 'x
随机数 = arr
End Function
Sub tt()
arr = 随机数(250, 1000, 750)
[b1].Resize(UBound(arr), 1) = Application.Transpose(arr)
End Sub

YANWEI82123300

虽然看不明白，不过正在努力学习

xj123321

学习学习     

xiaomils

下载学习了

深秋的黎明

只保留数字和英文的代码：
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
     .GetFromClipboard
     TextBox24.Text = .GetText '& Chr(10) & " OK  "
End With