module11.bas

适合乡镇供电所使用电费处理系统v3 软件

    While pos > 0
    s = Mid(s, 1, pos) & "'" & Mid(s, pos + 1)
    pos = InStr(pos + 2, s, "'")
    Wend
    
    CheckSQL = "'" & s & "'"
End Function

'/////////////渐变颜色///////////////////////

Sub Gradient(TheObject As Object, Redval&, Greenval&, Blueval&, TopToBottom As Boolean)
    Dim Step%, Reps%, FillTop%, FillLeft%, FillRight%, FillBottom%, HColor$
    Step = (TheObject.Height / 63)
    If TopToBottom = True Then FillTop = 0 Else FillTop = TheObject.Height - Step
    FillLeft = 0
    FillRight = TheObject.Width
    FillBottom = FillTop + Step
    For Reps = 1 To 63
        TheObject.Line (FillLeft, FillTop)-(FillRight, FillBottom), RGB(Redval, Greenval, Blueval), BF
        Redval = Redval - 4
        Greenval = Greenval - 4
        Blueval = Blueval - 4
        If Redval <= 0 Then Redval = 0
        If Greenval <= 0 Then Greenval = 0
        If Blueval <= 0 Then Blueval = 0
        If TopToBottom = True Then FillTop = FillBottom Else FillTop = FillTop - Step
        FillBottom = FillTop + Step
    Next
End Sub


'//////////渐变色彩函数///////////////////
Sub FormPaintColor(objName As Object, sigRedUp As Single, sigGreenUp As Single, sigBlueUp As Single, _
               sigRedDn As Single, sigGreenDn As Single, sigBlueDn As Single)
On Error Resume Next
Dim objHeight As Single
Dim RedInfo As Single, GreenInfo As Single, BlueInfo As Single
Dim Red As Single, Green As Single, Blue As Single
objHeight = objName.ScaleHeight
RedInfo = (sigRedDn - sigRedUp) / objHeight
GreenInfo = (sigGreenDn - sigGreenUp) / objHeight
BlueInfo = (sigBlueDn - sigBlueUp) / objHeight
For i = 0 To objHeight - 1
    Red = sigRedUp + i * RedInfo
    Green = sigGreenUp + i * GreenInfo
    Blue = sigBlueUp + i * BlueInfo
    objName.ForeColor = RGB(Red, Green, Blue)
    objName.Line (0, i)-(objName.ScaleWidth - 1, i)
Next i
End Sub

'///////////////////获取计算机用户名/////////////
Public Function sUserName() As String

Dim Bufstr As String
Bufstr = Space$(50)

If GetUserName(Bufstr, 50) > 0 Then
    sUserName = Bufstr
    sUserName = RTrim(sUserName)
    'UserName = StripTerminator(UserName)
Else
    sUserName = ""
End If
        
End Function

'////////////获取计算机名//////////////////

Function sGetComputerName() As String
  Dim sBuff As String
  Dim sBufSize As Long
  Dim sStatus As Long
  
  sBufSize = 255
  sBuff = String$(sBufSize, " ")
  sStatus = GetComputerName(sBuff, sBufSize)
  sGetComputerName = ""
  If sStatus <> 0 Then
     sGetComputerName = Left(sBuff, sBufSize)
  End If
  
End Function


'///////////////得知SHELL程序结束时间//////////////////////
Public Function StillRun(ByVal ProgramID) As Boolean
Dim lHProgram As Long
Dim lReturn As Long
hProgram = OpenProcess(0, False, ProgramID)
If Not hProgram = 0 Then
    StillRun = True
Else
    StillRun = False
End If
CloseHandle hProgram
End Function

'///////////////32字节校验函数/////////////////
Function A32(ByVal virString As String)
    Dim SLen As Long, i As Long
    Dim returnNum
    Static STP As Long
    STP = 0
    SLen = Len(virString)
    If SLen <> 64 Then
       MsgBox "数据错误！", vbCritical
    End If
    For i = 1 To SLen - 32
        If i = 1 Then
           returnNum = Mid(virString, i, 2)
        End If
        If i = 2 Then
           returnNum = "&H" & returnNum Xor "&H" & Trim(Mid(virString, i + 1, 2))
        End If
        If i = 3 Then
           returnNum = returnNum Xor "&H" & Trim(Mid(virString, i + 2, 2))
        End If
        If i > 3 Then
           STP = STP + 1
           returnNum = returnNum Xor "&H" & Trim(Mid(virString, i + STP + 2, 2))
        End If
    Next
    A32 = returnNum
End Function

Public Function Crypt(texti, salasana) As String
       '加密
       On Error Resume Next

              For T = 1 To Len(salasana)
                     sana = Asc(Mid(salasana, T))
                     X1 = X1 + sana
              Next

       X1 = Int((X1 * 0.1) / 6)
       salasana = X1
       G = 0
        For TT = 1 To Len(texti)
           sana = Asc(Mid(texti, TT))
             G = G + 1
             If G = 6 Then G = 0
               X1 = 0
                If G = 0 Then X1 = sana - (salasana - 2)
                  If G = 1 Then X1 = sana + (salasana - 5)
                    If G = 2 Then X1 = sana - (salasana - 4)
                      If G = 3 Then X1 = sana + (salasana - 2)
                        If G = 4 Then X1 = sana - (salasana - 3)
                          If G = 5 Then X1 = sana + (salasana - 5)
                            X1 = X1 + G
                              Crypted = Crypted & Chr(X1)
        Next
        Crypt = Crypted
End Function

Public Function DeCrypt(texti, salasana) As String
 '解密
       On Error Resume Next

              For T = 1 To Len(salasana)
                     sana = Asc(Mid(salasana, T))
                     X1 = X1 + sana
              Next

       X1 = Int((X1 * 0.1) / 6)
       salasana = X1
       G = 0
       For TT = 1 To Len(texti)
         sana = Asc(Mid(texti, TT))
           G = G + 1
            If G = 6 Then G = 0
             X1 = 0
             If G = 0 Then X1 = sana + (salasana - 2)
              If G = 1 Then X1 = sana - (salasana - 5)
               If G = 2 Then X1 = sana + (salasana - 4)
                If G = 3 Then X1 = sana - (salasana - 2)
                 If G = 4 Then X1 = sana + (salasana - 3)
                  If G = 5 Then X1 = sana - (salasana - 5)
                   X1 = X1 - G
                   DeCrypted = DeCrypted & Chr(X1)
       Next
       DeCrypt = DeCrypted
End Function

Sub sTruInfo()
    Select Case Val(GzYue)
           Case 1
              BenY = "A"
              ShangY = "L"
           Case 2
              BenY = "B"
              ShangY = "A"
           Case 3
              BenY = "C"
              ShangY = "B"
           Case 4
              BenY = "D"
              ShangY = "C"
           Case 5
              BenY = "E"
              ShangY = "D"
           Case 6
              BenY = "F"
              ShangY = "E"
           Case 7
              BenY = "G"
              ShangY = "F"
           Case 8
              BenY = "H"
              ShangY = "G"
           Case 9
              BenY = "I"
              ShangY = "H"
           Case 10
              BenY = "J"
              ShangY = "I"
           Case 11
              BenY = "K"
              ShangY = "J"
           Case 12
              BenY = "L"
              ShangY = "K"
           Case Else
              BenY = "A"
              ShangY = "L"
    End Select
    AA = BenY & "月示数"
    BB = BenY & "月调整电量"
    CC = BenY & "月电量"
    DD = BenY & "月合计电量"
    EE = BenY & "月调整金额"
    FF = BenY & "月滞纳金"
    GG = BenY & "月电费"
    HH = BenY & "月合计电费"
    II = BenY & "月代扣"
    JJ = BenY & "发票打印"
    KK = BenY & "交费情况"
    AAA = ShangY & "月示数"
    BBB = ShangY & "月电量"
    CCC = ShangY & "月电费"
    
End Sub

Public Function CaptureWindow(ByVal hWndSrc As Long, ByVal Client As Boolean, ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture
  Dim hDCMemory As Long
  Dim hBmp As Long
  Dim hBmpPrev As Long
  Dim r As Long
  Dim hDCSrc As Long
  Dim hPal As Long
  Dim hPalPrev As Long
  Dim RasterCapsScrn As Long
  Dim HasPaletteScrn As Long
  Dim PaletteSizeScrn As Long
  Dim LogPal As LOGPALETTE
  If Client Then
    hDCSrc = GetDC(hWndSrc)
  Else
    hDCSrc = GetWindowDC(hWndSrc)
  End If
  hDCMemory = CreateCompatibleDC(hDCSrc)
  hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
  hBmpPrev = SelectObject(hDCMemory, hBmp)
  RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS)
  HasPaletteScrn = RasterCapsScrn And RC_PALETTE
  PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE)
  If HasPaletteScrn And (PaletteSizeScrn = 256) Then
    LogPal.palVersion = &H300
    LogPal.palNumEntries = 256
    r = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
    hPal = CreatePalette(LogPal)
    hPalPrev = SelectPalette(hDCMemory, hPal, 0)
    r = RealizePalette(hDCMemory)
  End If
  r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy)
  hBmp = SelectObject(hDCMemory, hBmpPrev)
  If HasPaletteScrn And (PaletteSizeScrn = 256) Then
    hPal = SelectPalette(hDCMemory, hPalPrev, 0)
  End If
  r = DeleteDC(hDCMemory)
  r = ReleaseDC(hWndSrc, hDCSrc)
  Set CaptureWindow = CreateBitmapPicture(hBmp, hPal)
End Function


Public Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
  Dim r As Long
  Dim Pic As PicBmp
  Dim IPic As IPicture
  Dim IID_IDispatch As GUID
  With IID_IDispatch
    .Data1 = &H20400
    .Data4(0) = &HC0
    .Data4(7) = &H46
  End With
  With Pic
    .Size = Len(Pic)
    .Type = vbPicTypeBitmap
    .hBmp = hBmp
    .hPal = hPal
  End With
  r = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
  Set CreateBitmapPicture = IPic
End Function