财务分析 财财务分析务分析

        
         If .Fields("help_flag") Then                                 '是否提供帮助
            Textboolean(text_indexte, 1) = True
         End If
         If .Fields("Help_ManuFlag") Then                             '手工设置帮助按钮
            Textboolean(text_indexte, 3) = True
         End If
      
         If Not IsNull(.Fields("text_data_type")) Then                '字段数据类型
            Textint(text_indexte, 1) = .Fields("text_data_type")
         End If
         If Not IsNull(.Fields("help_type")) Then                     '帮助类型
            Textint(text_indexte, 2) = .Fields("help_type")
         End If
         If Not IsNull(.Fields("show_code_name")) Then                '帮助返回值显示类型
            Textint(text_indexte, 3) = .Fields("show_code_name")
         End If
         If Not IsNull(.Fields("judge_type")) Then                    '有效性判断类型
            Textint(text_indexte, 4) = .Fields("judge_type")
         End If
         If Not IsNull(.Fields("text_length")) Then                   '字段录入长度
            Textint(text_indexte, 5) = .Fields("text_length")
         End If
         If Not IsNull(.Fields("text_int_length")) Then               '数值字段整数位长度
            Textint(text_indexte, 6) = .Fields("text_int_length")
         End If
         If Not IsNull(.Fields("text_deci_length")) Then              '数值字段小数位长度
            Textint(text_indexte, 7) = .Fields("text_deci_length")
         End If
         If Not IsNull(.Fields("NotAllowEmpty_Type")) Then            '字段不允许为空或为零
            Textint(text_indexte, 8) = .Fields("NotAllowEmpty_Type")
         End If
         If Not IsNull(.Fields("Judge_Time")) Then                    '文本框有效性判断时刻
            Textint(text_indexte, 9) = .Fields("Judge_Time")
         End If
         
         
         Textstr(text_indexte, 1) = Trim(.Fields("text_index") & "")       '文本框对应索引值
         Textstr(text_indexte, 2) = Trim(.Fields("text_field_code") & "")  '文本框对应编码字段
         Textstr(text_indexte, 3) = Trim(.Fields("text_field_name") & "")  '文本框对应名称字段
         Textstr(text_indexte, 4) = Trim(.Fields("help_code") & "")        '通用帮助编码
         Textstr(text_indexte, 5) = Trim(.Fields("judge_base") & "")       '字段有效性判断依据
         Textstr(text_indexte, 6) = Trim(.Fields("error_message") & "")    '字段录入错误提示信息
         Textstr(text_indexte, 7) = Trim(.Fields("text_name") & "")        '文本框名称
               
         .MoveNext
      Loop
      
   End With
End Sub

Public Function XtWaitMess(Str_IndexSub)                         '系统功能调用等待提示
   '函数参数：系统功能模块索引号
   Xtcdcs = Str_IndexSub
   XT_FrmWaitMess.Show 1
End Function
Public Function Sub_FillPeriod(Combote As ComboBox, Year As Integer, Period As Integer)            '列表框填充会计期间

 '过程参数;填充列表框,会计年度,默认会计期间

 Dim Jsqte As Integer
 With Combote
     .Clear
     For Jsqte = 1 To 12
         .AddItem Mid(Trim(Str(10000 + Xtyear)), 2, 4) + "." + Mid(Trim(Str(100 + Jsqte)), 2, 2)
     Next Jsqte
     
     .Text = Mid(Trim(Str(10000 + Xtyear)), 2, 4) + "." + Mid(Trim(Str(100 + Period)), 2, 2)
 End With
End Function
'//* 功能: 金额小写转换为大写  调用参数:jesj...人民币小写金额
'//* 返回变量: name..人民币大写金额
Public Function Fun_Jezh(Jesj As Double) As String
Dim Name1$, Name2$, Mje1$, Name$
Dim len_mje1%, k%, ws%, j%, ws1%, m%
Dim Bz As Boolean
Name1 = "壹贰叁肆伍陆柒捌玖"
Name2 = "分角元拾佰仟万拾佰仟亿拾佰仟"
Mje1 = Trim(Format(Jesj, "###.00"))
len_mje1 = Len(Mje1)
If len_mje1 > 16 Or Jesj < 0.01 Or IsNull(Jesj) Then
   Fun_Jezh = ""
   Exit Function
End If
'//取无小数的字符串
Mje1 = Left(Mje1, len_mje1 - 3) + Right(Mje1, 2)
len_mje1 = len_mje1 - 1
k = len_mje1 * 2 - 1
ws = Int(Mid(Mje1, 1, 1)) * 2 - 1

If len_mje1 = 3 And ws < 0 Then     '//如果金额<1 name=''
    Name = ""
Else
    If ws > 0 Then
        Name = MidB(Name1, ws, 2) + MidB(Name2, k, 2) '//如果金额>=1,转换金额
    End If
End If
j = 2
k = k - 2
Bz = True
xh1:
Do While j <= len_mje1 And Bz
   ws1 = Int(Mid(Mje1, j, 1)) * 2 - 1
   If ws1 > 0 Then
      Name = Name + MidB(Name1, ws1, 2) + MidB(Name2, k, 2)
      j = j + 1
      k = k - 2
      GoTo xh1
   End If
   m = 0
xh2:
   Do While ws1 < 0
      If len_mje1 >= 11 Then
            If k < 21 Then
             m = m + 1
            End If
      End If
      If k = 5 Or (k = 13 And m <= 3) Or k = 21 Then
         Name = Name + MidB(Name2, k, 2)
      End If
      If k = 1 Then
         Name = Name + "整"
         Bz = False
         Exit Do
      End If
      j = j + 1
      k = k - 2
      ws1 = Int(Mid(Mje1, j, 1)) * 2 - 1
      If ws1 < 0 Then
         GoTo xh2
      Else
            If len_mje1 = 3 Then
                Name = Name + "零"
            Else
                Name = Name + "零"
            End If
      End If
   Loop
Loop

'去掉元和角之间零(1230.32)
wz1 = InStr(1, Name, "元")
wz2 = InStr(1, Name, "角")
If wz1 <> 0 And wz2 <> 0 Then
   wz3 = InStr(wz1, Name, "零")
   If wz3 <> 0 Then
      Name = Mid(Name, 1, wz3 - 1) + Mid(Name, wz3 + 1, Len(Name))
   End If
End If
Fun_Jezh = Name
End Function
Public Function Fun_FormatOutPut(InputText As String, OutPutLen As Integer) As String    '文本内容按一定标准格式输出
  
  '参数说明:InputText 需要格式化的文本内容 OutPutLen 输出文本占用长度(包括加空格)
  
  Fun_FormatOutPut = Trim(InputText) + Space(OutPutLen - Strcdcs(Trim(InputText), OutPutLen))
  
End Function
Public Function FillImageCombo(Combote As ImageCombo, ComboCode As String, AddType As Integer) '填充列表框(ImageCombo)并定位

  '函数参数：列表框(ImageCombo)，ComboCode列表框分组编码
  'AddType 项目填充类型(0-填充索引+内容,无空记录 1-仅填充内容,无空记录 2-填充索引+内容,有空记录 3-仅填充内容,有空记录)

  Dim Rec_Combo As ADODB.Recordset              '填充属性
  Dim Rec_FillText As ADODB.Recordset           '填充内容
  Dim ci As ComboItem
  Dim Jsqte As Integer                          '临时计数器
  
  Combote.ComboItems.Clear
  Jsqte = 1
  
  '填充列表框内容
  Set Rec_Combo = Cw_DataEnvi.DataConnect.Execute("Select * From Xt_ImageCombo Where combo_code='" + Trim(ComboCode) + "'")
  With Rec_Combo
    
    Combote.Locked = True
   
    If AddType = 2 Or AddType = 3 Then
       Set ci = Combote.ComboItems.Add(, "@")
       Jsqte = Jsqte + 1
    End If
    
    Set Rec_FillText = Cw_DataEnvi.DataConnect.Execute(Trim(.Fields("Sql_String")))
    
    Do While Not Rec_FillText.EOF
       Select Case AddType
          Case 0, 2                              '填充索引+内容
            Set ci = Combote.ComboItems.Add(, "@" + Trim(Rec_FillText.Fields(Trim(.Fields("ItemKey")))), Trim(Rec_FillText.Fields(Trim(.Fields("ItemKey")))) + " " + Trim(Rec_FillText.Fields(Trim(.Fields("ItemText")))))
          Case 1, 3                              '仅填充记录内容
            Set ci = Combote.ComboItems.Add(, "@" + Trim(Rec_FillText.Fields(Trim(.Fields("ItemKey")))), Trim(Rec_FillText.Fields(Trim(.Fields("ItemText")))))
       End Select
       Jsqte = Jsqte + 1
       Rec_FillText.MoveNext
    Loop
    If Combote.ComboItems.count <> 0 Then
       Combote.ComboItems.item(1).Selected = True
    End If
  End With
End Function
Public Function GetComboKey(Combote As ImageCombo, KeyOrName As Integer) As String      '取得用户选中列表框项目Key值或内容
    If DEBUG_FLAG = False Then On Error Resume Next
  '函数参数：列表框(ImageCombo),KeyOrName 0--取项目Key值 1--取选项内容值
  Dim Jsqte As Integer        '临时计数器
  
 If KeyOrName = 0 Then
  '去掉首位@
  For Jsqte = 1 To Combote.ComboItems.count
      If Combote.ComboItems(Jsqte).Text = Combote.Text Then
         Exit For
      End If
  Next Jsqte
  GetComboKey = Trim(Mid(Combote.ComboItems(Jsqte).Key, 2, Len(Combote.ComboItems(Jsqte).Key)))
 Else
  GetComboKey = Trim(Combote.Text)
 End If
 
End Function
Public Sub Sub_CodeScheme(ItemCodeTe As String, Int_CodeLev As Integer, Int_CodeScheme() As Integer)     '生成相应各级编码长度到数组中(编码方案)

'函数参数:ItemCodeTe 编码方案代码,Int_CodeLev 返回编码最大级数,Int_CodeScheme() 返回各级编码长度
'ForExample:会计科目编码:322222  结果:Int_CodeLev=6 Int_CodeScheme()=3 5 7 9 11 13
 
 Dim Rec_CodeScheme As New ADODB.Recordset   '编码方案动态集
 Set Rec_CodeScheme = Cw_DataEnvi.DataConnect.Execute("Select CodeScheme From Gy_CodeScheme Where ItemCode='" & Trim(ItemCodeTe) & "'")
 With Rec_CodeScheme
    If Not .EOF Then
       Int_CodeLev = Len(Trim(.Fields("CodeScheme")))
       ReDim Int_CodeScheme(Int_CodeLev)
       lenjsq = 0
       For Jsqte = 1 To Int_CodeLev
           lenjsq = lenjsq + Mid(Trim(.Fields("CodeScheme")), Jsqte, 1)
           Int_CodeScheme(Jsqte) = lenjsq
       Next Jsqte
    End If
    .Close
 End With
End Sub
Public Function Fun_GetIndex(ComboCodeTe As String, FindText As String) As String   '查找列表框内容对应索引号

  '函数参数：列表框分组编码，定位内容
  Dim Lbknrrec As ADODB.Recordset
  
  Fun_GetIndex = ""
  
  '填充列表框内容
  Set Lbknrrec = Cw_DataEnvi.DataConnect.Execute("select Item_Index from xt_combolist where combo_code='" & Trim(ComboCodeTe) & "' And Item_Content='" & Trim(FindText) & "'")
  
  With Lbknrrec
     If Not .EOF Then
        Fun_GetIndex = Trim(.Fields("Item_Index"))
     End If
  End With
End Function
Public Function Fun_GetContent(ComboCodeTe As String, FindIndex As String) As String   '查找列表框索引号对应内容

  '函数参数：列表框分组编码，定位内容
  Dim Lbknrrec As ADODB.Recordset
  
  Fun_GetContent = ""
  
  '填充列表框内容
  Set Lbknrrec = Cw_DataEnvi.DataConnect.Execute("select Item_Content from xt_combolist where combo_code='" & Trim(ComboCodeTe) & "' And Item_Index='" & Trim(FindIndex) & "'")
  
  With Lbknrrec
     If Not .EOF Then
        Fun_GetContent = Trim(.Fields("Item_Content"))
     End If
  End With
End Function
Public Sub Sub_SetOperStatus(Str_OperStatus As String)                                '显示系统操作状态
  If Trim(Str_OperStatus) <> "" Then
     XT_Main.StatusBar1.Panels("OperStatus") = Str_OperStatus
  Else
     XT_Main.StatusBar1.Panels("OperStatus") = "就绪"
  End If
End Sub
'==========系统权限控制与上机日志======================'
Public Function Security_Log(Gnsy As String, UserCode As String, Optional LogTF As Integer = 3, Optional State As Boolean = True) As Boolean   '权限判断和日志

'Gnsy 功能索引 UserCode 用户编码
'LogTF (1、判断权限，写日志)、（2、只写日志）、（3、只判断权限）
'State 状态 (True 进入 false 完成)
'返回Security_Log=true表示有权限，Security_Log=false表示没有有权限

Dim Tsxx As String              '系统信息提示

On Error Resume Next

Dim aDo_userGroup As New Recordset
Dim aDo_gnbm As New Recordset: Dim SSQL As String

Set aDo_gnbm = Cw_DataEnvi.DataConnect.Execute("select * from Xt_xtgnb where gnsy='" & Trim(Gnsy) & "'")
 
If LogTF = 1 Or LogTF = 3 Then
        Set aDo_userGroup = Cw_DataEnvi.DataConnect.Execute("select * from Xt_rygl where czybm='" & Trim(UserCode) & "'")
        
        If Mid(aDo_userGroup!AuthorityID, aDo_gnbm!Id, 1) = "1" Then
           Security_Log = True
           Else
           Security_Log = False
        End If
        aDo_userGroup.Close
        Set aDo_userGroup = Nothing
        
        If Security_Log = False Then
            Set aDo_userGroup = Cw_DataEnvi.DataConnect.Execute("select * from System_UserGroupInfo a ,System_UserGroup b where a.groupid=b.groupid and a.userid=" & Trim(UserCode))
            Do While Not aDo_userGroup.EOF
              If Mid(aDo_userGroup!AuthorityID, aDo_gnbm!Id, 1) = "1" Then
                  Security_Log = True
                  Exit Do
                Else
                  Security_Log = False
               End If
              aDo_userGroup.MoveNext
            Loop
            aDo_userGroup.Close
            Set aDo_userGroup = Nothing
        End If
        If Security_Log = False Then
           Tsxx = "没有权限,请与管理员联系！   "
           Call Xtxxts(Tsxx, 0, 4)
        End If
End If

'------------------------------------
If (LogTF = 1 And Security_Log = True) Or LogTF = 2 Then
  If State = True Then
     SSQL = "insert into System_Log(GeginDate,userid,WorkstationName,WorkList,SystemName,NetUserName,State)" _
          & " values(getdate()," & UserCode & ",'" & MachineName & "','" & Trim("" & aDo_gnbm!gnms) & "','" & "财务总帐管理系统" & "','" & NTDomainUserName & "','进入')"
    Else
     SSQL = "insert into System_Log(GeginDate,userid,WorkstationName,WorkList,SystemName,NetUserName,State)" _
          & " values(getdate()," & UserCode & ",'" & MachineName & "','" & Trim("" & aDo_gnbm!gnms) & "','" & "财务总帐管理系统" & "','" & NTDomainUserName & "','完成')"
  End If
  Cw_DataEnvi.DataConnect.Execute SSQL
End If
aDo_gnbm.Close
Set aDo_gnbm = Nothing

End Function
Public Function MachineName() As String                                         '取得当前工作站名
Dim sBuffer As String * 255
If GetComputerName(sBuffer, 255&) <> 0 Then
MachineName = Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1)
Else
MachineName = "(未知)"
End If
End Function
Public Function NTDomainUserName() As String                                    '取得当前网络用户名
Dim strBuffer As String * 255
Dim lngBufferLength As Long
Dim lngRet As Long
Dim strTemp As String

lngBufferLength = 255
lngRet = GetUserName(strBuffer, lngBufferLength)
strTemp = UCase(Trim$(strBuffer))
NTDomainUserName = Left$(strTemp, lngBufferLength - 1)

End Function