SAP EXCEL宏的使用

有很多业务场景需要对EXCEL的WORKSHEET,RANGE ,SHEET ,CELL, ROW, CLOUMN实时交互. 比如公式的自动计算，一个单元格的数据填充后，自动刷新汇总到另外的SHEET的单元格。楼栋的面积指标数据填写后，自动汇总更新到对应的分期和项目相同产品类型的面积指标上。还有EXCEL中实现按钮触发后台接口调用等。

'验证楼栋数据完整性
Public Function checkBuildingInput(star_rowindex As Integer) As Boolean
     '获取当前活动的sheet
     Dim csheet As Worksheet
     Set csheet = BuildingSheet
     Dim Msg As String: Msg = "楼栋填报模板sheet：" & Chr(10)
     Dim row_index As Integer
     Dim col_index As Integer
     Dim Result As Boolean: Result = True
     Dim check_flag As String
     
      '先显示所有列
     Application.ScreenUpdating = False
     '循环列
     BuildingSheet.Unprotect "123698745"
     For col_index = 7 To 32
        csheet.Cells(star_rowindex, col_index).EntireColumn.Hidden = False
     Next col_index
     Application.ScreenUpdating = True
     BuildingSheet.Protect "123698745@"
     
     
     If csheet.Range("A5").Value <> "0" Then
            '循环行
            For row_index = star_rowindex To CDbl(csheet.Range("A5").Value) + 7
               '循环列
                'For col_index = 7 To 14
                For col_index = 11 To 19                                             'modify by suyinghui 2017.09.14
                    '除车位列外其他列均不能为空
                    'If col_index <> 12 Then
                    check_flag = "X"
                    If ProjectSheet.Range("AB5") = "Z010" Then
                        If col_index = 12 Or col_index = 13 Or col_index = 16 Or col_index = 17 Then
                            check_flag = ""
                        End If
                    Else
                        If col_index = 17 Then
                            check_flag = ""
                        End If
                    End If
                     
                     If check_flag = "X" Then                                        'modify by suyinghui 2017.09.14
                        If csheet.Cells(row_index, col_index).MergeCells Then
                            If csheet.Cells(row_index, col_index).MergeArea.Row = row_index Then
                              If (csheet.Cells(row_index, col_index).Locked = False And csheet.Cells(row_index, col_index).Text = "") Then
                                  Msg = Msg & "第" & row_index & "行：" & Replace(csheet.Cells(6, col_index).Text, "*", "") & "不能为空" & Chr(10)
                                  Result = False
                              End If
                            End If
                        Else
                           If (csheet.Cells(row_index, col_index).Text = "") Then
                                Msg = Msg & "第" & row_index & "行：" & Replace(csheet.Cells(6, col_index).Text, "*", "") & "不能为空" & Chr(10)
                                Result = False
                           End If
                        End If
                     End If
                     
                     '建筑面积
                     'If col_index = 7 Then
                         'If (VarType(csheet.Cells(row_index, col_index).Text) = vbDouble And CDbl(csheet.Cells(row_index, col_index).Text) <= 0) Then
                             'Msg = Msg & "第" & row_index & "行：" & Replace(csheet.Cells(6, col_index).Text, "*", "") & "不能小于0" & Chr(10)
                             'Result = False
                         'End If
                     'End If
                     
                     
                     
                       
               Next col_index
            Next row_index
    End If
    
    
     
    If Result = False Then
       'MessageBoxHandle.ShowMessageBox (Msg)
       MsgBox (Msg)
     End If
     checkBuildingInput = Result
End Function
'验证分期数据完整性
Public Function checkStageInput(star_rowindex As Integer) As Boolean
   
     '获取当前活动的sheet
     Dim csheet As Worksheet
     Set csheet = StageSheet
     Dim Msg As String: Msg = "分期填报模板sheet：" & Chr(10)
     Dim row_index As Integer
     Dim col_index As Integer
     Dim Result As Boolean: Result = True
     Dim check_flag As String
     For row_index = star_rowindex To CDbl(csheet.Range("A6").Value) + 7
        '循环列
        For col_index = 10 To 23
        
            '除车位列外其他列均不能为空
            
            check_flag = "X"
            If ProjectSheet.Range("AB5") = "Z010" Then
                If col_index = 15 Or col_index = 16 Or col_index = 19 Or col_index = 20 Then
                    check_flag = ""
                End If
            Else
                If col_index = 20 Then
                    check_flag = ""
                End If
            End If
            If check_flag = "X" Then
                If csheet.Cells(row_index, col_index).MergeCells Then
                    If csheet.Cells(row_index, col_index).MergeArea.Row = row_index Then
                      If (csheet.Cells(row_index, col_index).Locked = False And csheet.Cells(row_index, col_index).Text = "") Then
                          Msg = Msg & "第" & row_index & "行：" & Replace(csheet.Cells(7, col_index).Text, "*", "") & "不能为空" & Chr(10)
                          Result = False
                      End If
                      
                       '总用地面积 净用地面积 建筑物基底面积 建筑面积不能小于0
                        'If col_index = 6 Or col_index = 7 Or col_index = 8 Or col_index = 11 Then
                            'If (VarType(csheet.Cells(row_index, col_index).Text) = vbDouble And CDbl(csheet.Cells(row_index, col_index).Text) <= 0) Then
                                'Msg = Msg & "第" & row_index & "行：" & Replace(csheet.Cells(7, col_index).Text, "*", "") & "不能小于0" & Chr(10)
                                'Result = False
                            'End If
                        'End If
                    End If
                Else
                   If (csheet.Cells(row_index, col_index).Text = "") Then
                        Msg = Msg & "第" & row_index & "行：" & Replace(csheet.Cells(7, col_index).Text, "*", "") & "不能为空" & Chr(10)
                        Result = False
                   End If
                   '总用地面积 净用地面积 建筑物基底面积 建筑面积不能小于0
                    'If col_index = 6 Or col_index = 7 Or col_index = 8 Or col_index = 11 Then
                        'If (VarType(csheet.Cells(row_index, col_index).Text) = vbDouble And CDbl(csheet.Cells(row_index, col_index).Text) <= 0) Then
                            'Msg = Msg & "第" & row_index & "行：" & Replace(csheet.Cells(7, col_index).Text, "*", "") & "不能小于0" & Chr(10)
                            'Result = False
                        'End If
                    'End If
                End If
             End If
             
           
        
        Next col_index
       
        
     Next row_index
     
    If Result = False Then
       MsgBox (Msg)
     End If
     checkStageInput = Result
End Function

'验证项目数据完整性
Public Function checkProjectInput(star_rowindex As Integer) As Boolean
     '获取当前活动的sheet
     Dim csheet As Worksheet
     Set csheet = StageSheet
     Dim Msg As String: Msg = "项目填报模板sheet：" & Chr(10)
     Dim row_index As Integer
     Dim col_index As Integer
     Dim Result As Boolean: Result = True
     Dim check_flag As String
     For row_index = star_rowindex To CDbl(csheet.Range("A5").Value) + 7
        '循环列
        For col_index = 7 To 16
        
            check_flag = "X"
            If ProjectSheet.Range("AB5") = "Z010" Then
                If col_index = 12 Or col_index = 13 Then
                    check_flag = ""
                End If
            Else
                
            End If
            
                If csheet.Cells(row_index, col_index).MergeCells Then
                    If csheet.Cells(row_index, col_index).MergeArea.Row = row_index Then
                      If (csheet.Cells(row_index, col_index).Locked = False And csheet.Cells(row_index, col_index).Text = "") Then
                          Msg = Msg & "第" & row_index & "行：" & Replace(csheet.Cells(6, col_index).Text, "*", "") & "不能为空" & Chr(10)
                          Result = False
                      End If
                      
                      '总用地面积 净用地面积 建筑物基底面积 建筑面积不能小于0
                        'If col_index = 4 Or col_index = 5 Or col_index = 6 Or col_index = 9 Then
                            'If (VarType(csheet.Cells(row_index, col_index).Text) = vbDouble And CDbl(csheet.Cells(row_index, col_index).Text) <= 0) Then
                                'Msg = Msg & "第" & row_index & "行：" & Replace(csheet.Cells(6, col_index).Text, "*", "") & "不能小于0" & Chr(10)
                                'Result = False
                            'End If
                        'End If
                    End If
                Else
                   If (csheet.Cells(row_index, col_index).Text = "") Then
                        Msg = Msg & "第" & row_index & "行：" & Replace(csheet.Cells(7, col_index).Text, "*", "") & "不能为空" & Chr(10)
                        Result = False
                   End If
                   '总用地面积 净用地面积 建筑物基底面积 建筑面积不能小于0
                    'If col_index = 4 Or col_index = 5 Or col_index = 6 Or col_index = 9 Then
                        'If (VarType(csheet.Cells(row_index, col_index).Text) = vbDouble And CDbl(csheet.Cells(row_index, col_index).Text) <= 0) Then
                            'Msg = Msg & "第" & row_index & "行：" & Replace(csheet.Cells(6, col_index).Text, "*", "") & "不能小于0" & Chr(10)
                            'Result = False
                        'End If
                    'End If
                End If
        Next col_index
       
        
     Next row_index
     
    If Result = False Then
       MsgBox (Msg)
     End If
     checkProjectInput = Result
End Function

'本模块用于实现认证相关功能
Option Explicit

'用户登录，弹出登录框
Public Function Login() As Long
    '域认证以后补充
    '弹出登录框
    LoginForm.Show
    Login = LoginForm.getRtnValue
    
End Function

'本模块用于存储系统基础变量
Option Explicit

'记录调用服务的地址
Public ServiceAddress As String

'记录系统名称
Public SysName As String

'当前用户ID
Public CurrentUserId As Long

'当前用户拥有的权限
Public UserPermission() As String

'当前用户拥有的权限的字符串形式
Public UserPermissionStr As String
'工作表保护密码
Public ProtectPassword As String
'数据分隔符(行)
Public SeparateRow As String
'数据分隔符(列)
Public SeparateColumn As String
'分隔符(表)
Public SeparateTable As String
'楼栋change事件运行次数
Public change_times As Integer

'初始化系统变量
Public Function InitSys() As Boolean
    On Error GoTo err
    '设置工作表保护密码
    Let ProtectPassword = "123698745@"
   
   
        
    Dim LoginResult As Long
    '初始化系统名称
    SysName = ""
   
    '获取登录结果
    LoginResult = Login()
    '将用户名添加到单元格中
    'ThisWorkbook.Sheets("shtSummary").Range("A3").Value2 = LoginResult
    
     '撤销保护使用的sheet
    ProjectSheet.Unprotect ProtectPassword
    BuildingSheet.Unprotect ProtectPassword
    StageSheet.Unprotect ProtectPassword
    ProjectSheet.Range("A8:P" & ProjectSheet.UsedRange.Rows.Count).Locked = True
    StageSheet.Range("A7:E" & StageSheet.UsedRange.Rows.Count).Locked = True
    StageSheet.Range("F7:R" & StageSheet.UsedRange.Rows.Count).Locked = False
    BuildingSheet.Range("A8:F" & BuildingSheet.UsedRange.Rows.Count).Locked = True
    '保护使用的heet
    ProjectSheet.Protect ProtectPassword, AllowInsertingColumns:=False, AllowInsertingRows:=False, AllowDeletingColumns:=False, AllowDeletingRows:=False, AllowFormattingColumns:=True, AllowFormattingRows:=True, AllowFormattingCells:=True
    BuildingSheet.Protect ProtectPassword, AllowInsertingColumns:=False, AllowInsertingRows:=False, AllowDeletingColumns:=False, AllowDeletingRows:=False, AllowFormattingColumns:=True, AllowFormattingRows:=True, AllowFormattingCells:=True
    StageSheet.Protect ProtectPassword, AllowInsertingColumns:=False, AllowInsertingRows:=False, AllowDeletingColumns:=False, AllowDeletingRows:=False, AllowFormattingColumns:=True, AllowFormattingRows:=True, AllowFormattingCells:=True
   
   
    '初始化成功
    InitSys = True
    Exit Function

err:
    '初始化失败
    InitSys = False
    MsgBox err.Description, vbOKOnly + vbExclamation, SysName
End Function

'系统初始化失败后处理
Public Sub InitSysFailHandle()

End Sub

'记录文本
Sub TextStreamTest(ByVal context As String)
    '**如果引用“windows script host object model”,可以定义如下的数据类型，编程更方便!!!!*******
    Dim fs As FileSystemObject, f As File, ts As TextStream, s As String
    '打开一个只读文件，不能对此文件进行写操作/
    '打开一个用于写操作的文件。如果和此文件同名的文件已存在，则覆盖以前内容/
    '打开一个文件并写到文件的尾部
    Const ForReading = 1, ForWriting = 2, ForAppending = 8
    '使用系统缺省打开文件/以 Unicode 格式打开文件/以 ASCII 格式打开文件
    Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
    'Dim fs, f, ts, s
    Set fs = CreateObject("Scripting.FileSystemObject")
    'FileSystemObject 对象提供对计算机文件系统的访问
    '下面FileSystemObject.CreateTextFile 返回一个 TextStream 对象，该对象是可读并可写的：
    On Error Resume Next  '如果文件存在，下个命令会出错！获得文件
    fs.CreateTextFile("C:/test1.txt", False).WriteLine ("This is a test.") '创建一个文件,返回一个用于该文件读写的TextStream对象
    Set f = fs.GetFile("C:/test1.txt")          '返回一个和指定路径中文件相对应的 File 对象
    '错误！f.WriteLine ("This is a test.")          '向创建的文本文件中写入一行文本，非TextStream对象，错误！！
      
    Set ts = f.OpenAsTextStream(ForAppending, TristateUseDefault) '打开一个指定的文件并返回一个 TextStream 对象
    'OpenAsTextStream 方法提供了和 FileSystemObject. 的 OpenTextFile 方法相同的功能/
    '此外，OpenAsTextStream 方法还可以用于对一个文件进行写操作。
    ts.Write context
    ts.Close
    Set ts = f.OpenAsTextStream(ForReading, TristateUseDefault)
    Do While Not ts.AtEndOfStream
        s = ts.ReadLine
        'MsgBox s
    Loop
    ts.Close
End Sub

'VB Base64 编码/加密函数：
  
Function Base64Encode(str() As Byte) As String                                  'Base64 编码
    On Error GoTo over                                                          '排错
    
    Dim buf() As Byte, length As Long, mods As Long
    Const B64_CHAR_DICT = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/="
    mods = (UBound(str) + 1) Mod 3   '除以3的余数
    length = UBound(str) + 1 - mods
    ReDim buf(length / 3 * 4 + IIf(mods <> 0, 4, 0) - 1)
    Dim i As Long
    For i = 0 To length - 1 Step 3
        buf(i / 3 * 4) = (str(i) And &HFC) / &H4
        buf(i / 3 * 4 + 1) = (str(i) And &H3) * &H10 + (str(i + 1) And &HF0) / &H10
        buf(i / 3 * 4 + 2) = (str(i + 1) And &HF) * &H4 + (str(i + 2) And &HC0) / &H40
        buf(i / 3 * 4 + 3) = str(i + 2) And &H3F
    Next
    If mods = 1 Then
        buf(length / 3 * 4) = (str(length) And &HFC) / &H4
        buf(length / 3 * 4 + 1) = (str(length) And &H3) * &H10
        buf(length / 3 * 4 + 2) = 64
        buf(length / 3 * 4 + 3) = 64
    ElseIf mods = 2 Then
        buf(length / 3 * 4) = (str(length) And &HFC) / &H4
        buf(length / 3 * 4 + 1) = (str(length) And &H3) * &H10 + (str(length + 1) And &HF0) / &H10
        buf(length / 3 * 4 + 2) = (str(length + 1) And &HF) * &H4
        buf(length / 3 * 4 + 3) = 64
    End If
    For i = 0 To UBound(buf)
        Base64Encode = Base64Encode + Mid(B64_CHAR_DICT, buf(i) + 1, 1)
    Next
over:
End Function

'获取base64加密结果
Function GetBase64EncodeResul(sou_str As String) As String
    Dim sou_code() As Byte
    Dim i, kk As Integer
    
    kk = Len(sou_str) - 1
    ReDim sou_code(kk)
    For i = 0 To kk
        sou_code(i) = Asc(Mid(sou_str, i + 1, 1))
    Next i
  
    kk = UBound(sou_code)
    GetBase64EncodeResul = Base64Encode(sou_code())
    
End Function

'根据请求码获取ws的Url
Function GetWsUrl(serviceCode As String) As String
    If serviceCode = "220" Then
        GetWsUrl = ProjectSheet.Range("AD6").Value
    ElseIf serviceCode = "300" Then
        GetWsUrl = ProjectSheet.Range("AE6").Value
    ElseIf serviceCode = "310" Then
        GetWsUrl = ProjectSheet.Range("AE6").Value
    ElseIf serviceCode = "360" Then
        GetWsUrl = ProjectSheet.Range("AE6").Value
    ElseIf serviceCode = "600" Then
        GetWsUrl = ProjectSheet.Range("AF6").Value
    End If
End Function

'根据请求码获取接口请求的加密账号和密码
Function GetAuthorization(serviceCode As String) As String
    If serviceCode = "220" Then
        GetAuthorization = GetBase64EncodeResul(ProjectSheet.Range("AD7").Value)
    ElseIf serviceCode = "300" Then
        GetAuthorization = GetBase64EncodeResul(ProjectSheet.Range("AE7").Value)
    ElseIf serviceCode = "310" Then
        GetAuthorization = GetBase64EncodeResul(ProjectSheet.Range("AE7").Value)
    ElseIf serviceCode = "360" Then
        GetAuthorization = GetBase64EncodeResul(ProjectSheet.Range("AE7").Value)
    ElseIf serviceCode = "600" Then
        GetAuthorization = GetBase64EncodeResul(ProjectSheet.Range("AF7").Value)
    End If
End Function

'暂存事件
Sub SaveData()
    
    Call