分類目錄歸檔:VBscript

VB實現類繼承的另類方法

之前為了實現公司業務對比的功能,用VB寫了個小工具去供應商處采集數據,通過本工具對業務進行對比。剛開始供應商比較少,沒有按類的對象(類)的編寫。隨著供應商的增加,兩三年下來,供應商已經增加到近20家,每家都有三四大類產品線。為了共用某些代碼(XMLHTTP,正則,登錄判斷),代碼都寫到了一個模塊里。

近期,有供應商改版了,需要對程序進行調整,發現僅采集模塊就有1500行代碼,基本都在一個過程(Sub)里,每改一次簡直要瘋一次。如果把公用方法寫到一個類里,然后各個供應商都繼承(Extend)這個類,豈不美哉。發現VB不是完全面向對象的語言,基本都是說道不可能。在貼吧一個帖子里(http://tieba.baidu.com/p/1795854449)提到VB6.0實現類的繼承,用他的代碼測試,也沒有解決。簡直是坑啊。。。。。實際他做到的是Implements。 繼續閱讀

巧用ASPJPEG做驗證碼識別程序

在寫程序實現 發帖/回帖 中,驗證碼識別是一個非常重要的工具。今天我就來些這樣一個工具。

首先需要創建文字表(A),然后去識別原圖(B)。然后截出某字符的圖片,比較第一個像素(0,0)的差值,第二個像素的差值(0,1)的差值,然后。。。。最終差值最小的就是識別出的字符。

說起來有點繞口,實際很簡單。直接上代碼了(VBS對圖像處理較弱,所以用到ASPJPEG組件)。

下載地址:http://www.okfdzs1809.com/products/ocr.rar

繼續閱讀

ASP的Base64函數

  Const BASE_64_CHARACTERS = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
  Private sBASE_64_CHARACTERS

  Function Base64encode(ByVal asContents)
    asContents = strUnicode2Ansi(asContents)
    Dim lnPosition,lsResult,Char1,Char2,Char3,Char4,Byte1,Byte2,Byte3,SaveBits1,SaveBits2,lsGroupBinary,lsGroup64,M4, len1, len2
    len1 = LenB(asContents)
    If len1 < 1 Then
      Base64encode = ""
      Exit Function
    End If
    M4 = len1 Mod 3
    If M4 > 0 Then asContents = asContents & String(3 - M4, Chr(0))
    '補足位數是為了便于計算
    If M4 > 0 Then
      len1 = len1 + (3 - M4)
      len2 = len1 - 3
    Else
      len2 = len1
    End If
    lsResult = ""
    sBASE_64_CHARACTERS = strUnicode2Ansi(BASE_64_CHARACTERS)
    For lnPosition = 1 To len2 Step 3
      lsGroup64 = ""
      lsGroupBinary = MidB(asContents, lnPosition, 3)
      Byte1 = AscB(MidB(lsGroupBinary, 1, 1)): SaveBits1 = Byte1 And 3
      Byte2 = AscB(MidB(lsGroupBinary, 2, 1)): SaveBits2 = Byte2 And 15
      Byte3 = AscB(MidB(lsGroupBinary, 3, 1))
      Char1 = MidB(sBASE_64_CHARACTERS, ((Byte1 And 252) \ 4) + 1, 1)
      Char2 = MidB(sBASE_64_CHARACTERS, (((Byte2 And 240) \ 16) Or (SaveBits1 * 16) And &HFF) + 1, 1)
      Char3 = MidB(sBASE_64_CHARACTERS, (((Byte3 And 192) \ 64) Or (SaveBits2 * 4) And &HFF) + 1, 1)
      Char4 = MidB(sBASE_64_CHARACTERS, (Byte3 And 63) + 1, 1)
      lsGroup64 = Char1 & Char2 & Char3 & Char4
      lsResult = lsResult & lsGroup64
    Next
    '處理最后剩余的幾個字符
    If M4 > 0 Then
      lsGroup64 = ""
      lsGroupBinary = MidB(asContents, len2 + 1, 3)
      Byte1 = AscB(MidB(lsGroupBinary, 1, 1)): SaveBits1 = Byte1 And 3
      Byte2 = AscB(MidB(lsGroupBinary, 2, 1)): SaveBits2 = Byte2 And 15
      Byte3 = AscB(MidB(lsGroupBinary, 3, 1))
      Char1 = MidB(sBASE_64_CHARACTERS, ((Byte1 And 252) \ 4) + 1, 1)
      Char2 = MidB(sBASE_64_CHARACTERS, (((Byte2 And 240) \ 16) Or (SaveBits1 * 16) And &HFF) + 1, 1)
      Char3 = MidB(sBASE_64_CHARACTERS, (((Byte3 And 192) \ 64) Or (SaveBits2 * 4) And &HFF) + 1, 1)
      If M4 = 1 Then
        lsGroup64 = Char1 & Char2 & ChrB(61) & ChrB(61) '用=號補足位數
      Else
        lsGroup64 = Char1 & Char2 & Char3 & ChrB(61) '用=號補足位數
      End If
      lsResult = lsResult & lsGroup64
    End If
    Base64encode = strAnsi2Unicode(lsResult)
  End Function

  Function Base64decode(ByVal asContents)
    asContents = strUnicode2Ansi(asContents)
    Dim lsResult,lnPosition,lsGroup64, lsGroupBinary,Char1, Char2, Char3, Char4,Byte1, Byte2, Byte3,M4, len1, len2
    len1 = LenB(asContents)
    M4 = len1 Mod 4

    If len1 < 1 Or M4 > 0 Then
      '字符串長度應當是4的倍數
      Base64decode = ""
      Exit Function
    End If
    '判斷最后一位是不是 = 號
    '判斷倒數第二位是不是 = 號
    '這里m4表示最后剩余的需要單獨處理的字符個數
    If MidB(asContents, len1, 1) = ChrB(61) Then M4 = 3
    If MidB(asContents, len1 - 1, 1) = ChrB(61) Then M4 = 2
    If M4 = 0 Then
      len2 = len1
    Else
      len2 = len1 - 4
    End If
    sBASE_64_CHARACTERS = strUnicode2Ansi(BASE_64_CHARACTERS)
    For lnPosition = 1 To len2 Step 4
      lsGroupBinary = ""
      lsGroup64 = MidB(asContents, lnPosition, 4)
      Char1 = InStrB(sBASE_64_CHARACTERS, MidB(lsGroup64, 1, 1)) - 1
      Char2 = InStrB(sBASE_64_CHARACTERS, MidB(lsGroup64, 2, 1)) - 1
      Char3 = InStrB(sBASE_64_CHARACTERS, MidB(lsGroup64, 3, 1)) - 1
      Char4 = InStrB(sBASE_64_CHARACTERS, MidB(lsGroup64, 4, 1)) - 1
      Byte1 = ChrB(((Char2 And 48) \ 16) Or (Char1 * 4) And &HFF)
      Byte2 = lsGroupBinary & ChrB(((Char3 And 60) \ 4) Or (Char2 * 16) And &HFF)
      Byte3 = ChrB((((Char3 And 3) * 64) And &HFF) Or (Char4 And 63))
      lsGroupBinary = Byte1 & Byte2 & Byte3
      lsResult = lsResult & lsGroupBinary
    Next
    '處理最后剩余的幾個字符
    If M4 > 0 Then
      lsGroupBinary = ""
      lsGroup64 = MidB(asContents, len2 + 1, M4) & ChrB(65) 'chr(65)=A,轉換成值為0
      If M4 = 2 Then '補足4位,是為了便于計算
        lsGroup64 = lsGroup64 & ChrB(65)
      End If
      Char1 = InStrB(sBASE_64_CHARACTERS, MidB(lsGroup64, 1, 1)) - 1
      Char2 = InStrB(sBASE_64_CHARACTERS, MidB(lsGroup64, 2, 1)) - 1
      Char3 = InStrB(sBASE_64_CHARACTERS, MidB(lsGroup64, 3, 1)) - 1
      Char4 = InStrB(sBASE_64_CHARACTERS, MidB(lsGroup64, 4, 1)) - 1
      Byte1 = ChrB(((Char2 And 48) \ 16) Or (Char1 * 4) And &HFF)
      Byte2 = lsGroupBinary & ChrB(((Char3 And 60) \ 4) Or (Char2 * 16) And &HFF)
      Byte3 = ChrB((((Char3 And 3) * 64) And &HFF) Or (Char4 And 63))
      If M4 = 2 Then
        lsGroupBinary = Byte1
      ElseIf M4 = 3 Then
        lsGroupBinary = Byte1 & Byte2
      End If
      lsResult = lsResult & lsGroupBinary
    End If
    Base64decode = strAnsi2Unicode(lsResult)
  End Function

  Function strUnicodeLen(ByVal asContents)
    '計算unicode字符串的Ansi編碼的長度
    Dim asContents1
    Dim len1,k,i,asc1
    asContents1 = "a" & asContents
    len1 = Len(asContents1)
    k = 0
    For i = 1 To len1
      asc1 = Asc(Mid(asContents1, i, 1))
      If asc1 < 0 Then asc1 = 65536 + asc1
      If asc1 > 255 Then
        k = k + 2
      Else
        k = k + 1
      End If
    Next
    strUnicodeLen = k - 1
  End Function

  Function strUnicode2Ansi(ByVal asContents)
    '將Unicode編碼的字符串,轉換成Ansi編碼的字符串
    Dim len1,i,VarChar,varAsc,varHex, varlow, varhigh
    strUnicode2Ansi = ""
    len1 = Len(asContents)
    For i = 1 To len1
      VarChar = Mid(asContents, i, 1)
      varAsc = Asc(VarChar)
      If varAsc < 0 Then varAsc = varAsc + 65536
      If varAsc > 255 Then
        varHex = Hex(varAsc)
        varlow = Left(varHex, 2)
        varhigh = Right(varHex, 2)
        strUnicode2Ansi = strUnicode2Ansi & ChrB("&H" & varlow) & ChrB("&H" & varhigh)
      Else
        strUnicode2Ansi = strUnicode2Ansi & ChrB(varAsc)
      End If
    Next
  End Function

  Function strAnsi2Unicode(asContents)
    '將Ansi編碼的字符串,轉換成Unicode編碼的字符串
    Dim len1,i,VarChar,varAsc
    strAnsi2Unicode = ""
    len1 = LenB(asContents)
    If len1 = 0 Then Exit Function
    For i = 1 To len1
      VarChar = MidB(asContents, i, 1)
      varAsc = AscB(VarChar)
      If varAsc > 127 Then
        strAnsi2Unicode = strAnsi2Unicode & Chr(AscW(MidB(asContents, i + 1, 1) & VarChar))
        i = i + 1
      Else
        strAnsi2Unicode = strAnsi2Unicode & Chr(varAsc)
      End If
    Next
  End Function

程序員買房的笑話

google很給力的筆試題:現在北京有一套房子,價格200萬,假設房價每年上漲10%,一個軟件工程師每年固定能賺40萬。如果他想買這套房子,不貸款,不漲工資,沒有其他收入,每年不吃不喝不消費,那么他需要幾年才能攢夠錢買這套房子?
繼續閱讀

用FileDB快速開發生成靜態系統

最近要用到一套ASP生成靜態的小系統,雖然說程序簡單,但是寫起來還是比較繁瑣的,正好前幾天寫過一個:ASP文件存儲方案(http://www.okfdzs1809.com/p/asp-filedb),用改類,可以直接快速開發生成ASP的系統。

  '加載模板
  '對于模板,不了解的,可以參考我以前寫過的文章,當然也可以用任何asp的模板系統
  set p = new MYW3_TPL
  p.LoadTpl "tpl/chengyu.html"
  p.assign "Title","貓七"
  p.assign "WebHome",WebHome
  p.assign "WebSkin",WebSkin
  
  '/index.html
  url = "index"
  '/home/index.html
  'url = "home::index"
  '/home/1/2/333.html
  'url = "home::1::2::333"
  '生成靜態
  ‘使用FileDB類,超級簡單
  set f = new FileDB
  f.DBPath = "/"
  f.idxKey = url
  f.save(p.outHtml)

需要對FileDB的類做一下小的修改

Private Function getPath()
    Dim tmp
    getPath = replace(idxKey,"::","/") & ".html"
  End Function

ASP文本存儲方案-FileDB

四月份做個一個短信系統,當時為了節省成本(使用萬網的空間,不帶SQL數據庫空間便宜),使用了ASP+Access開發,最近需要升級,增加一個短信接口。發現現在Access的數據庫竟然有170MB。我的天啊,因為查詢比較少,不是很耗資源,所以沒有檢查出來。
僅僅六個月,數據庫竟然到了170MB。隨著客戶業務的增長,可能再過六個月就要到500MB了,真恐怖。主要占空間大小的,就是存儲的短信的發送號碼,思考再三,決定將所有的保存到文本文件中。于是寫下了一個暫時成為FileDB的asp類。

Class FileDB
  Dim fso,IdxKey,DBPath
  Private Sub Class_Initialize
    Set fso = Server.CreateObject("Scripting.FileSystemObject")
    idxKey = "demo::test"
    DBPath = "DataCenter/File_DB/"
  End Sub

  Private Function getPath()
    Dim tmp
    getPath = replace(idxKey,"::","/") & ".html"
  End Function

  Private Function checkFile(byref fname)
    fname = Server.Mappath(DBPath & getPath())
    checkFile = fso.fileexists(fname)
  End Function

  Private Sub createPathName(byval idxKey)
    Dim TmpPa
    TmpPa = Server.Mappath(DBPath & idxKey)
    if not fso.folderexists(TmpPa) then
      if instr(idxKey,"\") > 0 then Call createPathName(left(idxKey,instrrev(idxKey,"\")-1))
      fso.createfolder(TmpPa)
    end if
  End Sub

  Public Function getTxt()
    if checkFile(fname) then
      set Txt = fso.getfile(fname)
      if Txt.size = 0 then
        Tmp = ""
      else
        Tmp = fso.opentextfile(fname).readall
      end if
      set Txt = Nothing
      getTxt = Tmp
    else
      getTxt = ""
    end if
  End Function

  Public Function remove()
    if checkFile(fname) then
      fso.deletefile fname
    end if
  End Function

  Public Function Save(byval content)
    if checkFile(fname) then
      set fpo = fso.opentextfile(fname,2)
    else
      idxKey = replace(idxKey,"::","\")
      if instr(idxKey,"\")>0 then Call createPathName(left(idxKey,instrrev(idxKey,"\")-1))
      set fpo = fso.createtextfile(fname)
    end if
    fpo.write content
    fpo.close
    set fpo = nothing
  End Function
End Class

因為時間比較緊,而且代碼比較簡單,就不加注釋了,實際就是簡化了文本文件的操作方法。

<% Server.ScriptTimeOut=10000 %> 
<%
  '數據庫鏈接代碼
  
  set fdb = new FileDB
  fdb.DBPath = "../DataCenter/sms_DB/"
    
  conn.open constr
  set rs = server.createobject("ADODB.Recordset")
  '得到所有沒有轉換的數據
  rs.open "select * from sendlog where send_mob not like '%::%'",conn,3,2
  do while not rs.eof
    'FileDB 數據存放路徑,日期::MD5(ID)
    idxStr = split(Rs("send_date")," ")(0) & "::" & md5(Rs("send_id"))
    fdb.IdxKey = idxStr
    fdb.Save(Rs("send_mob"))
    Rs("send_mob") = idxStr
    rs.update
    rs.movenext
  loop
  rs.close
  conn.close
  
  '數據庫壓縮過程,不是重點,再次不再多述
  compactdata(DataPath)
%>
減肥成功,所有數據轉存到FileDB中。

執行一下,所有數據就轉存好了,讀取的時候很簡單,指定了 idxStr,用getTxt()即可得到內容。

  set fdb = new FileDB
  fdb.DBPath = "../DataCenter/sms_DB/"
  '../DataCenter/sms_DB/aaa/1111.txt
  fdb.idxKey = "aaa::1111"
  str1 = fdb.getTxt()
  '../DataCenter/sms_DB/bbb/ccc/ddd/eee.txt
  fdb.idxKey = "bbb:ccc::ddd:eee"
  str2 = fdb.getTxt()
  '刪除 ../DataCenter/sms_DB/bbb/ccc/ddd/eee.txt
  fdb.remove() 
  '因為文件不存在,得到的值就是空字符串
  str3 = fdb.getTxt()
  '將內容保存到../DataCenter/sms_DB/bbb/ccc/ddd/eee.txt,因為不存在則創建,如果存在,則修改。
  fdb.save("11111")

2010年10月24日更新小Bug,修復了idxKey 定于數據存放在根目錄,就會報錯的錯誤