Option Explicit
Const wdAutoFitWindow=2
Const wdPageBreak=2
Dim SHeader,PageCounter,aSheets,aRepIds,aChts
dim Years,Months,Products,SelectProduct,SelectRegion,YearMonth
dim sPrintTypeN,sTypePrint,RPSN'sPrintTypeN指打印方式,如打印和导出,sTypePrint指打印按,如打印按区域
dim oFSO,sWordApp,oWordDoc,sRecycleFolder,sFold,sYMFolder,nTopPriceAveCount
dim ErrStr '记录全局的错误信息在一个字符串上
'*********************************************************************************************************
'********************************************************************************************
'按给定的表达式,对指定的字段调用Top函数,Top 数根据对应表格的数值自动计算
'********************************************************************************************
sub TopMarket10 '本月市场综合占有率按市场品牌名称Top10
Call TopMarket(10)
end sub
sub TopCountryPriceAve '本月全国平均价格排名
Call TopPriceAve(0)
end sub
sub TopRegionPriceAve '本月全国平均价格排名
Call TopPriceAve(1)
end sub
sub TopCountrySaleQua
Call TopSaleQua(0)
end sub
sub TopRegionSaleQua
Call TopSaleQua(1)
end sub
sub TopCountrySaleQty
Call TopSaleQty(0)
end sub
sub TopRegionSaleQty
Call TopSaleQty(1)
end sub
Function TopSaleQua(npa) '本月零售额
dim Num,sField
TopSaleQua=True
sField="品牌名称"
Num=TopFilter("CH09",sField,npa)
if Num=0 then
TopSaleQua=false
exit function
elseif Num>50 then
Num=50
end if
'msgbox Num
Call top(Num,sField,"sum(本月零售额)")
end Function
function TopSaleQty(npa) '本月零售量
dim Num,sField
TopSaleQty=True
sField="品牌名称"
Num=TopFilter("CH14",sField,npa)
if Num=0 then
TopSaleQty=false
exit function
elseif Num>50 then
Num=50
end if
'msgbox Num
Call top(Num,sField,"sum(本月零售量)")
end function
'本月平均价格,npa=0为全国,1为地区
'npa<3 表示固定Top npa
Function TopPriceAve(npa)
dim Num,sField
TopPriceAve=True
sField="品牌名称"
if npa<3 then
Num=TopFilter("CH18",sField,npa)
if Num=0 then TopPriceAve=false : exit function
else
Num=npa
end if
'msgbox Num
Call top(Num,sField,"Sum(本月零售额)/Sum(本月零售量)")
end Function
'市场综合占有率,npa=0为全国,1为地区
'npa<3 表示固定Top npa
Function TopMarket(npa)
dim Num,sField
TopMarket=True
sField="市场品牌名称"
if npa<3 then
Num=TopFilter("CH02",sField,npa)
else
Num=npa
end if
'msgbox Num
Call top(Num,sField,"(sum(本月品牌销量)/TMSumSaleQty)*0.4+(sum(本月品牌销售次数)/TMSumSaleCount)*0.6")
end Function
'地区c指标,npa=0为全国,1为地区
'npa<3 表示固定Top npa
Function TopIndexC(npa)
dim Num,sField
TopIndexC=True
sField="商场名称"
if npa<3 then
Num=TopFilter("CH08",sField,npa)
if Num=0 then
TopIndexC=false
exit function
elseif Num>50 then
Num=50
end if
else
Num=npa
end if
'msgbox Num
Call top(Num,"商场名称","sum(今年本月C值)")
end Function
'********************************************************************************************
'获取sCht在sField全选时首列中的Total值,将其赋给变量RowCount,并将其作为函数值返回
'备注:此处首列total必须设为total Count
'********************************************************************************************
function TopFilter(sCht,sField,nPa)'nPa=0 为全国,=1为地区
dim Num,LastRowValue,RowCount
'如果没有指定获取行数的Cht,则取其字段可选值数
if sCht="" then
'msgbox sField
Set RowCount=ActiveDocument.Fields(sField).GetpossibleValues'optionalValues
Num=RowCount.count 'optional
else
Call GetUpdateVar(sField,sCht,0,"RowCount")
Num=GetVarValue("RowCount")
LastRowValue=GetTableValue(sCht,2,2)'获取表中第2列倒数第2行的值
if LastRowValue="-" or LastRowValue="0" then Num=Num-1
end if
'对Top Num过滤
if npa=1 then
if Num>20 then
Num=20
else
Num=Int(Num/5)*5
end if
else
if Num>100 then
Num=100
elseif Num>50 then
Num=50
else
Num=Int(Num/10)*10
end if
end if
TopFilter=Num
end function
'********************************************************************************************
'按表达式expf对字段sField进行Top Num Select
Sub Top(Num, sfield, expf)
dim f
if Num=0 then exit sub
ActiveDocument.Variables("top").SetContent Num, True
Set f = ActiveDocument.Fields(sfield)
f.Clear
f.TopSelect expf, Num
End Sub
'===============================================================================================
'********************************************************************************************
'将表CH09和CH14对字段 品牌名称 全选时的Total值(最后一行)分别赋给变量_
'TotalSaleQua,TotalSaleQty
'备注调用GetUpdateVa更改变量值前,先执行维度关联过程Asscociatedemension
'********************************************************************************************
Sub ActiveUpdate
Call Asscociatedemension
Call GetUpdateVar("品牌名称","CH09",2,"TotalSaleQua")
Call GetUpdateVar("品牌名称","CH14",2,"TotalSaleQty")
End Sub
'********************************************************************************************
'将表CH36对字段 市场品牌名称 全选时的Total值(最后一行)分别赋给变量_
'TMSumSaleCount,TMSumSaleQty,LMSumSaleCount,LMSumSaleQty的值
'备注调用GetUpdateVa更改变量值前,先执行维度关联过程Asscociatedemension
'********************************************************************************************
Sub ActiveUpdate2
dim i,sheet,aVars(4),ShtID
Call Asscociatedemension
' Set Sheet=ActiveDocument.ActiveSheet.GetProperties
' ShtID=Right(Sheet.SheetId,4)
' if ShtID="SH09" or ShtID="SH20" or ShtID="SH08" or ShtID="SH29" or ShtID="SH22" or ShtID="SH21" then
aVars(1)="TMSumSaleCount":aVars(2)="TMSumSaleQty"
aVars(3)="LMSumSaleCount":aVars(4)="LMSumSaleQty"
for i=1 to 4
Call GetUpdateVar("市场品牌名称","CH36",i,aVars(i))
next
'msgbox ShtID&"ActiveUpdate2"
' end if
end sub
'********************************************************************************************
'获取表(表名sPt)中倒数nH行,第Column列的值,由函数名GetTableValue将值返回
'********************************************************************************************
Function GetTableValue(sPt,Column,nH)
dim table,oCht,h,Cell
set table = ActiveDocument.GetSheetObject(sPt) '获取Total值的 Table
h=table.GetRowCount-nH 'nH为倒数第行序号
Set Cell=table.GetCell(h,Column)
'Call UpdateVarValue(sVal,Cell.Text) 'VarBrandCount
GetTableValue=Cell.text
End Function
'********************************************************************************************
'在表(表名sPt)中字段sField中全选时,获取其最后一行第Column列的Total值
'通过调用函数UpdateVarValue将该值赋给变量sVal
'********************************************************************************************
Function GetUpdateVar(sField,sPt,Column,sVal)
dim table,oCht,h,Cell
ActiveDocument.Fields(sField).selectall 'sPt对象中的维度字段
set table = ActiveDocument.GetSheetObject(sPt) '获取Total值的 Table
h=table.GetRowCount-1
Set Cell=table.GetCell(h,Column)
Call UpdateVarValue(sVal,Cell.Text) 'VarBrandCount
ActiveDocument.Fields(sField).Clear
End Function
'********************************************************************************************
'将变量(sVarName为变量名)的值更改为VarValue
'********************************************************************************************
sub UpdateVarValue(sVarName,VarValue)
ActiveDocument.Variables(sVarName).SetContent varvalue,true
End Sub
'********************************************************************************************
'获取变量sVarName的值,作为函数值GetVarValue返回
'********************************************************************************************
function GetVarValue(sVarName)
GetVarValue=ActiveDocument.Variables(sVarName).GetContent.string
End function
'===============================================================================================
'********************************************************************************************
'维度选择值自动关联,此函数由字段Select事件调用
'涉及的维度和对应关系举例:年==>市场年
'********************************************************************************************
Sub Asscociatedemension
dim i,Sheet,fieldname
set Sheet=ActiveDocument.ActiveSheet
for i=0 to Sheet.NoOfSheetObjects-1
if(Sheet.SheetObjects(i).IsActive) then
fieldname=Sheet.SheetObjects(i).GetCaption.Name.v
exit for
end if
next
Select Case fieldname
Case "年"
Call YearAssociate
Case "月"
Call MonthAssociate
Case "地区名称"
Call RegionAssociate
Case "产品子类产品名称"
Call SubNameAssociate
Case "市场年"
Call MarketYearAssociate
Case "市场月"
Call MarketMonthAssociate
Case "市场地区名称"
Call MarketRegionAssociate
Case "市场产品子类产品名称"
Call MarketSubNameAssociate
Case Else
End Select
End Sub
'********************************************************************************************
'********************************************************************************************
'依据defaultValue是否为空,不为空就将字段sField置为单选状态
function IsOneSelect(sField,defaultValue)
dim fld,p
set fld = ActiveDocument.GetField(sField)
if fld.GetSelectedValues.count<>1 then fld.select defaultValue
set p = fld.GetProperties
if defaultValue="" then
p.OneAndOnlyOne = false
else
p.OneAndOnlyOne = true
end if
fld.SetProperties p
End function
'将市场月置为单选状态,设当前月份为默认值
sub OneMarketMonthSelect
call IsOneSelect("市场月",cstr(month(date)))
End sub
'将市场月置为复选状态
sub NotOneMarketMonthSelect
call IsOneSelect("市场月","")
End sub
'将月置为单位状态,设当前月份为默认值
sub OneMonthSelect
call IsOneSelect("月",cstr(month(date)))
End sub
'将月置为复选状态
sub NotOneMonthSelect
call IsOneSelect("月","")
End sub
'********************************************************************************************
'将地区名称 和 市场地区名称 按参数nPa进行关联,下同
Sub RegionAssociate
Call AssociateField("地区名称","市场地区名称",0)
end sub
Sub YearAssociate
Call AssociateField2("年","市场年",0)
end sub
Sub QuaterAssociate
Call AssociateField2("季","市场季",0)
end sub
Sub MonthAssociate
Call AssociateField2("月","市场月",0)
end sub
Sub SubcategoryAssociate
Call AssociateField2("产品子类编码","C产品子类编码",2)
end Sub
Sub IndexCSubcategoryAssociate
Call AssociateField2("C产品子类编码","产品子类编码",2)
end Sub
Sub SubNameAssociate
Call AssociateField("产品子类产品名称","市场产品子类名称",0)
end Sub
Sub BrandAssociate
Call AssociateField("品牌名称","市场品牌名称",0)
end sub
Sub MarketRegionAssociate
Call AssociateField("市场地区名称","地区名称",0)
end sub
Sub MarketYearAssociate
Call AssociateField2("市场年","年",0)
end sub
Sub MarketQuaterAssociate
Call AssociateField2("市场季","季",0)
end sub
Sub MarketMonthAssociate
Call AssociateField2("市场月","月",0)
end sub
Sub MarketSubNameAssociate
Call AssociateField("市场产品子类名称","产品子类产品名称",0)
end Sub
Sub MarketBrandAssociate
Call AssociateField("市场品牌名称","品牌名称",0)
end sub
'********************************************************************************************
'********************************************************************************************
'按SelField字段选中的值,将RelField字段也选中同样的值
'npa代表第一个参数获取方式,0--3分别为选中,未选中,可选,不可选
Function AssociateField(SelField,RelField,npa)
dim i,Count,osf,Orf,sSelectValues,fv
Set oSf = ActiveDocument.Fields(SelField)
sSelectValues = LoadSelect(SelField,npa)
Set oRf=ActiveDocument.Fields(RelField)
oRf.Clear
Set fv=oRf.GetNoValues
For i = 0 To Ubound(sSelectValues) - 1
fv.Add
fv(i).text=sSelectValues(i)
fv(i).IsNumeric=false
Next
oRf.SelectValues fv
End Function
Function AssociateField2(SelField,RelField,npa)
dim i,Count,osf,Orf,sSelectValues
Set oSf = ActiveDocument.Fields(SelField)
sSelectValues = LoadSelect(SelField,npa)
Set oRf=ActiveDocument.Fields(RelField)
oRf.Clear
For i = 0 To Ubound(sSelectValues) - 1
oRf.Select sSelectValues(i)
Next
End Function
'字段SelField按npa值(一般为2,可选值optional)自动选中所有可选值
Function AutoSelect(SelField,npa)
dim i,osf,sOptionalValues,Count,fv
Set oSf = ActiveDocument.Fields(SelField)
sOptionalValues = LoadSelect(SelField,npa)
Set fv=oSf.GetNoValues
For i = 0 To Ubound(sOptionalValues) - 1
fv.Add
fv(i).text= sOptionalValues(i)
fv(i).IsNumeric=false
Next
oSf.SelectValues fv
end function
'===============================================================================================
'================================以下为Report创建函数模块================================================
'*******************************************************************
'创建Report报表，
'aRepIds:Report ID 数组,存放如"RP02"的String串
'aChts:对应Report ID 的Item数组,存放如"CH01, CH02"的String串
'*******************************************************************
Sub CreateReport
Dim oDoc',aChts', aRepIds
Dim i, RepCount,RectMatrix,temp,temp2,MatrixString,k,m,n
SHeader="中国商业联合会"&year(date)&"年"&month(date)&"月"&"零售统计报表"
Set oDoc = ActiveDocument
oDoc.ClearDocReports
aSheets = Array("SH09", "SH10", "SH19", "SH16","SH12","SH12","SH15","SH07", "SH07", "SH07", "SH20", "SH08", "SH08", "SH08", "SH19", "SH16", "SH12", "SH12", "SH15", "SH09","SH22","SH24","SH24","SH24")
aRepIds = Array("RP01", "RP02", "RP03", "RP04", "RP05", "RP06", "RP07", "RP08", "RP09", "RP10", "RP11","RP12", "RP13", "RP14","RP15","RP16","RP17","RP18","RP19","RP20","RP21","RP22","RP23","RP24")
aChts = Array( "TX30,TX29,TX23,CH02,TX24,CH05", _
"TX30,TX29,TX27,CH06,CH22", _
"TX30,TX29,TX20,CH14", _
"TX30,TX29,TX39,CH09", _
"TX30,TX29,TX02,CH18", _
"TX30,TX29,TX02,CH18", _
"TX43,TX29,TX14,CH08", _
"TX30,TX29,TX21,CH24", _
"TX30,TX29,TX21,CH24", _
"TX30,TX29,TX21,CH24", _
"TX30,TX29,CH23", _
"TX30,TX29,TX25,CH01,TX46,CH21,TX46", _
"TX30,TX29,TX25,CH01,TX46,CH21,TX46", _
"TX30,TX29,TX25,CH01,TX46", _
"TX30,TX29,TX40,CH27", _
"TX30,TX29,TX16,CH26", _
"TX30,TX29,TX02,CH30", _
"TX30,TX29,TX01,CH70", _
"TX43,TX29,TX14,CH28", _
"TX30,TX29,TX23,CH31,TX24,CH32", _
"TX31,TX44", _
"TX51,TX49,CH38", _
"TX52,TX49,CH38", _
"TX53,TX49,CH38")
MatrixString=Array("0,3,1000,60;10,60,1000,30;20,70,961,84;20,150,968,380;20,569,961,34;20,632,950,338", _
"0,3,1000,60;10,60,1000,30;20,70,785,66;30,136,914,410;30,555,914,410", _
"0,3,1000,60;10,60,1000,30;20,128,983,91;20,216,996,458", _
"0,3,1000,60;10,60,1000,30;20,128,983,91;20,216,996,458", _
"0,3,1000,60;10,60,1000,30;20,128,983,91;20,216,996,458", _
"0,3,1000,60;10,60,1000,30;20,128,983,91;20,216,996,458", _
"0,3,1000,60;10,60,1000,30;20,128,983,91;20,216,996,458", _
"0,3,1000,60;10,60,1000,30;20,70,879,35;25,115,980,410", _
"0,3,1000,60;10,60,1000,30;20,70,879,35;25,115,980,410", _
"0,3,1000,60;10,60,1000,30;20,70,879,35;25,115,980,410", _
"0,0,1000,300;0,115,1000,30;0,151,1000,848", _
"0,3,1000,60;10,60,1000,30;20,70,785,66;30,136,914,410;111,520,888,60;30,555,914,410;111,940,888,60", _
"0,3,1000,60;10,60,1000,30;20,70,785,66;30,136,914,410;111,520,888,60;30,555,914,410;111,940,888,60", _
"0,3,1000,60;10,60,1000,30;20,70,785,66;30,136,914,410;111,520,888,60", _
"0,3,1000,60;10,60,1000,30;20,65,983,91;20,110,996,911", _
"0,3,1000,60;10,60,1000,30;20,65,983,91;20,110,996,911", _
"0,3,1000,60;10,60,1000,30;20,65,983,91;20,110,996,911", _
"0,3,1000,60;10,60,1000,30;20,65,983,91;20,110,996,911", _
"0,3,1000,60;10,60,1000,30;20,65,983,91;20,110,996,911", _
"0,3,1000,60;10,60,1000,30;20,70,961,84;20,150,968,380;20,569,961,34;20,632,950,338", _
"0,0,1000,1000;13,505,986,159", _
"0,0,1000,50;0,51,1000,30;0,100,1000,900", _
"0,0,1000,50;0,51,1000,30;0,100,1000,900", _
"0,0,1000,50;0,51,1000,30;0,100,1000,900")
RepCount=Ubound(aRepIds)
For i = 0 To RepCount
temp=split(Matrixstring(i),";")
k=Ubound(temp)
Redim RectMatrix(k,3)
for m=0 to k
temp2=split(temp(m),",")
for n=0 to 3
RectMatrix(m,n)=temp2(n)/1000
next
next
if ReportAdd(oDoc, aRepIds(i),Split(aChts(i), ","),RectMatrix)=false then
Call ReturnMsg(Err.Description&chr(10)&"报表创建失败,请重试",48,0)
Exit for
End if
Next
End Sub
'*******************************************************************
'oDoc:需增加打印报表的文档对象;sRPtId:报表Id号
'aChts:报表上放置的打印对象ID号数组,元素如"CH01","CH02"
'注意:name and Comment调用了公共变量SHeader, SComment,如移植请增加
'*******************************************************************
Function ReportAdd(oDoc,sRepId,aChts,Rect)
dim rep,i,nItemCount,oItem
nItemCount = UBound(aChts)
oDoc.RemoveDocReport sRepId
Set Rep = oDoc.GetApplication.CreateEmptyReport
With Rep
.Id = sRepId
.Name = SHeader&sRepId '移植时此处需要修改
'.Comment = SComment
'.PrintOptions.Header_Left = SHeader '.Footer_Center = ""
.Pages.Add
.Pages.Item(0).Landscape =false 'True为横排打印,增加参数
.Pages.Item(0).PageMode = 0 '1为Multi paper page
End With
if sRepId="RP11" then Rep.Pages.Item(0).Landscape =true
for i=0 to nitemcount
rep.Pages.Item(0).Items.Add
set oItem=rep.Pages.Item(0).Items.Item(i)
with oItem
.ObjectId = aChts(i)
.Rect.Left =Rect(i,0) 'left
.Rect.Top =Rect(i,1) 'top
'.Clip = 3
.Rect.Width = Rect(i,2) 'paper width
.Rect.Height = Rect(i,3) 'paper height,1=Whole
End With
next
oDoc.AddDocReport rep
ReportAdd=true
'ActiveDocument.PrintDocReport "RP02",打印是由其他模块来完成的
End Function
'====================================Report创建函数模块结束==============================================
Sub UpdatePrintType
dim PrintType,N
PrintType=LoadSelect("打印按",0)
Select Case PrintType(0)
case "打印按套打":N=0
case "打印按区域":N=1
case "打印按报表":N=2
case else :N=-1
End Select
if n<2 then Call UpdateVarValue("sRPSN",-1)
Call UpdateVarValue("TypePrint",N)
end sub
Sub UpdateRPSN
dim aTemp
aTemp=LoadSelect("SN",2)
Call UpdateVarValue("sRPSN",aTemp(0))
end sub
'====================================以下为报表打印模块==================================================
'*******************************************************************
'打印Report报表,sRepID为报表ID号,根据sPrintTypeN参数是否该报表导出到Word
'*******************************************************************
Function printReport(sRepId)
dim Rep,TempRepID,index
Err.Clear
'On Error Resume Next
printReport=true
TempRepID="RP100"
ActiveDocument.RemoveDocReport TempRepID
Set Rep=ActiveDocument.GetDocReport(sRepId)
Rep.PrintOptions.Footer_Center = PageCounter
Rep.ID=TempRepID
Rep.Name="Temp Report for Print"
ActiveDocument.AddDocReport Rep
If mid(sRepId,3,1)="0" then
index=Clng(Right(sRepId,1))
else
index=Clng(Right(sRepId,Len(sRepId)-2))
end if
ActiveDocument.sheets(aSheets(index-1)).Activate
'msgbox sRepId&" "&PageCounter '查看打印每一页
if left(sPrintTypeN,2)="打印" then
'ActiveDocument.PrintDocReport sRepId
'ActiveDocument.PrintDocReport TempRepID 'print report
end if
if right(sPrintTypeN,2)="导出" then Call writeToWord(oWordDoc,sRepId)
PageCounter=PageCounter+1
if Err.Number<>0 then
printReport=false
Call ReturnMSg("打印报表失败"&chr(10)&RepId&chr(10)&"错误号："& Err.Number& _
" 错误描述： "&Err.Description,48,0)
end if
set Rep=nothing
End function
'*************************************************************
Sub CycPrintProductSub '循环产品子类打印Report
dim i,j,ProductField,IndexCField,sRPSN
dim Lockobj,LockYear,LockMonth,sWordDocName
dim t1,t2
t1=now
Err.clear
'On Error Resume Next
ProductField="产品子类产品名称":IndexCField="C指标名称"
sRPSN=GetVarValue("sRPSN")
if sRPSN=6 then
Redim Products(1)
Products(0)="C指标报表"
else
Products=LoadSelect(ProductField,0)
end if
Years=LoadSelect("年",0):Months=Loadselect("月",0)
if Ubound(years)*Ubound(Months)*Ubound(Products)=0 or Ubound(Months)>1 Then
Call ReturnMsg("年.月.产品字段漏选或多选,请重新选择",32,0)
Exit Sub
end if
YearMonth=Years(0)&"年"&Months(0)&"月"
Call UpdateVarValue("YearMonth",YearMonth)
sPrintTypeN=GetVarValue("PrintTypeN")
If ReturnMsg("确认"&sPrintTypeN&"选中产品子类的所有报表吗?",36,1)=6 then
Call CreateReport
if right(sPrintTypeN,2)="导出" then Call CreateForWord
Call UpdateVarValue("PrintVisual",1)
For i = 0 To Ubound(Products)-1
Call AttachChart
SelectProduct=Products(i)
'msgbox Years(0)&" "&SelectProduct &" "&Months(0)
if right(sPrintTypeN,2)="导出" then set oWordDoc=sWordApp.Documents.Add
Call UpdateVarValue("SubProduct",SelectProduct)
Call FilterToPrint
ActiveDocument.sheets("SH21").Activate
'msgbox Products(i) &"类别 的所有报表打印完毕,共打印了 "& PageCounter & "页,请核对"
PageCounter=0 '页码置0
if right(sPrintTypeN,2)="导出" then
sWordDocName=sYMFolder&"\"&YearMonth&SelectProduct&".doc"'fullfilename
Call SaveWord(oWordDoc,sWordDocName)
Set oWordDoc=Nothing
end if
Next
if right(sPrintTypeN,2)="导出" then Call QuitWord
ActiveDocument.sheets("SH21").Activate
Call UpdateVarValue("PrintVisual",0)
ActiveDocument.UnlockAll
ActiveDocument.ClearAll True
t2=now
ReturnMsg sPrintTypeN&"完毕,共耗时 "&minute(t2-t1)&" 分"&second(t2-t1)&" 秒",64,0
Call AttachChart
End If
'msgbox Err.Number&" "&Err.description
if Err.Number<>0 or Len(ErrStr)>0 then ReturnMsg ErrStr&Chr(10)&Err.description,48,0
End Sub
Function FilterToPrint
dim aArea,aTemp,aCRepIDs,aRRepIDs,i
sTypePrint=GetVarValue("TypePrint")
Select Case sTypePrint
Case 0 '打印按套打
aCRepIDs=Array("RP20","RP11","RP15","RP16","RP17","RP19")
aRRepIDs=Array("RP01","RP02","RP03","RP04","RP05","RP07","RP08")
aArea=Array("华北","东北","华东","中南","西南","西北")
'套打时才打印封面
if printReport("RP21")=false then exit Function
ActiveDocument.ClearAll true '清除未锁定的选择
Call PrintCountry(aCRepIDs) '打印全国报表
Call PrintRegion(aRRepIDs,aArea) '打印地区报表
Case 1 '打印按区域
aArea=LoadSelect("打印区域",0)
if aArea(0)="全国" then
aCRepIDs=Array("RP20","","RP15","RP16","RP17","RP19")
ActiveDocument.ClearAll true '清除未锁定的选择
Call PrintCountry(aCRepIDs) '打印全国报表
else
aTemp=Array(aArea(0))
aRRepIDs=Array("RP01","","RP03","RP04","RP05","RP07","RP08")
ActiveDocument.ClearAll true '清除未锁定的选择
Call PrintRegion(aRRepIDs,aTemp) '打印地区报表
end if
Case 2 '打印按报表
aArea=Array("华北","东北","华东","中南","西南","西北")
aCRepIDs=Array("RP20","RP11","RP15","RP16","RP17","RP19")
aRRepIDs=Array("RP01","RP02","RP03","RP04","RP05","RP07")
aTemp=LoadSelect("SN",2)
RPSN=Cint(aTemp(0))
if RPSN<6 then
for i=0 to 5
if i<>RPSN then
aCRepIDs(i)=""
aRRepIDs(i)=""
end if
Next
ActiveDocument.ClearAll true '清除未锁定的选择
Call PrintCountry(aCRepIDs) '打印全国报表
Call PrintRegion(aRRepIDs,aArea) '打印地区报表
else
ActiveDocument.ClearAll true
Call PrintIndexCRePort
end if
Case else
End Select
End Function
'打印全国报表,按RPID数组循环打印
sub PrintCountry(aCRepID)
dim i,j,iMin,iMax,RepID',aCRepID
dim sSheetID,aChts(1),aRepIds(2)
if sTypePrint<=1 then
iMin=0 : iMax=5
else
iMin=RPSN: iMax=RPSN
end if
'aCRepID=Array("RP20","RP11","RP15","RP16","RP17","RP19")
for i=iMin to iMax '打印全国前6张Table
RepID=aCRepID(i)
Call LockProduct(SelectProduct,0)
'======================================================
if i<=1 then
Call LockMKyear(Years(0),0)
Call LockMKmonth(months(0),0)
ActiveDocument.Fields("市场地区名称").SelectAll
Call ActiveUpdate2
else
Call Lockyear(Years(0),0)
Call Lockmonth(months(0),0)
ActiveDocument.Fields("地区名称").SelectAll
Call ActiveUpdate
end if
'======================================================
if RepID<>"" then
if (i<>4 and i<>2) or ProductSubFilter(SelectProduct)=True then '产品子类过滤平均价格表
if i=5 then '此处必须在i=5时才调用LockIndexC
if LockIndexC=false then
ErrStr=ErrStr&"没有找到与"&SelectProduct&"对应的C指标名称,全国50大主销商场报表缺失"&Chr(10)
exit for
end if
end if
if TopSelectforPrint(i,0)=true then
if i=4 then
Call printReport(RepID)
if nTopPriceAveCount=100 then call printReport("RP18")
else
Call printReport(RepID)
end if
end if
end if
end if
'======================================================
ActiveDocument.ClearAll true
next
'打印三张全国重点品牌柱状图
if sTypePrint<2 then
Call LockProduct(SelectProduct,0)
Call LockMKyear(Years(0),0)
Call LockMKmonth(months(0),0)
sSheetID="SH08"
aChts(0)="CH01":aChts(1)="CH21"
aRepIds(0)="RP12":aRepIds(1)="RP13":aRepIds(2)="RP14"
Call PrintBrandTop5(sSheetID,aChts,aRepIds)
ActiveDocument.ClearAll true
End if
End sub
'打印地区报表,按RPID和Region数组循环打印
Sub PrintRegion(aRRepID,Regions)
dim i,j,iMin,iMax,Flag
Dim RepID,CycField(2),SelectRegion
if sTypePrint<2 then
iMin=0 : iMax=6
else
iMin=RPSN: iMax=RPSN
end if
'msgbox Ubound(Regions)
CycField(1)="地区名称":CycField(2)="市场地区名称"
'Regions=Array("华北","东北","华东","中南","西南","西北")
'aRRepID=Array("RP01","RP02","RP03","RP04","RP05","RP07","RP08") 'RP08为地区Time趋势线
for i=iMin to iMax '打印地区7张Table
Call LockProduct(SelectProduct,0)
RepID=aRRepID(i)
'======================================================
if i<2 or i=6 then '前2张和第7张为市场维度控制
Call LockMKyear(Years(0),0)
Call LockMKmonth(months(0),0)
ActiveDocument.Fields(CycField(1)).Clear
CycField(0)=CycField(2)
else '其他为正常维度控制
Call Lockyear(Years(0),0)
Call Lockmonth(months(0),0)
ActiveDocument.Fields(CycField(2)).Clear
CycField(0)=CycField(1)
end if
'======================================================
if RepID<>"" then
if (i<>4 and i<>2) or ProductSubFilter(SelectProduct)=true then '产品子类过滤平均价格表
Flag=True
if i=5 then
if LockIndexC=false then
ErrStr=ErrStr&"没有找到与"&SelectProduct&"对应的C指标名称,地区20大主销商场报表缺失"&Chr(10)
Flag=false
end if
end if
if Flag=True then
For j = 0 To Ubound(Regions)'-1 '循环打印每个地区的6张报表
SelectRegion=Regions(j)
'msgbox j&SelectRegion&Ubound(Regions)&CycField(0)
ActiveDocument.Fields(CycField(0)).Select SelectRegion
if i=6 then
Call LockField("市场品牌名称","",1)
Call LockField("市场月",months(0),0)
Call ActiveUpdate2
Call TopMarket(3)
Call LockField("市场品牌名称","",0)
Call LockField("市场月","",1)
ActiveDocument.Fields("市场月").Select "<="&months(0) '打印地区的趋势图
else
Call ActiveUpdate
Call ActiveUpdate2
end if
if TopSelectforPrint(i,1)=true then 'npa=1为地区
if printReport(RepId)=false then exit sub
end if
Next
end if
end if
end if
'======================================================
ActiveDocument.ClearAll true
next
End Sub
'***********************************************************************************************
'***********************************************************************************************
'过滤不打印平均价格表的产品子类,函数返回True为打印,False为不打印
function ProductSubFilter(SelectProduct)
dim aPSubFilter,i
ProductSubFilter=True
aPSubFilter=Array("美发用品","护肤品") '维护不打印平均价格表的产品子类,请修改此处
for i=0 to Ubound(aPSubFilter)
if SelectProduct=aPSubFilter(i) then
ProductSubFilter=false
exit for
end if
Next
end function
'npa=0为Lock,否则为Unlock,下同
Sub LockProduct(Values,npa)
Call LockField("产品子类产品名称",Values,npa)
Call LockField("市场产品子类名称",Values,npa)
end sub
Sub LockMonth(Values,npa)
Call LockField("月",Values,npa)
end sub
Sub LockYear(Values,npa)
Call LockField("年",Values,npa)
end sub
Sub LockMKMonth(Values,npa)
Call LockField("市场月",Values,npa)
end sub
Sub LockMKYear(Values,npa)
Call LockField("市场年",Values,npa)
end sub
function LockIndexC
LockIndexC=true
if Err.Number<>0 then ErrStr=Err.description
Err.Clear
On Error Resume Next
Call AssociateField2("产品子类编码","C产品子类编码",2)
Call AutoSelect("C指标名称",2)
ActiveDocument.Fields("C指标名称").Lock
ActiveDocument.Fields("产品子类产品名称").unLock
ActiveDocument.Fields("产品子类产品名称").Clear
ActiveDocument.Fields("品牌名称").Clear
if Err.Number<>0 then LockIndexC=false
End function
Sub LockField(sField,Value,npa)
dim osf
Set osf=ActiveDocument.Fields(sField)
if npa=0 then
if Len(Value)>0 then ActiveDocument.Fields(sField).Select Value
ActiveDocument.Fields(sField).lock
else
ActiveDocument.Fields(sField).unlock
end if
end Sub
'***********************************************************************************************
'***********************************************************************************************
' "TX30,TX29,TX23,CH02,TX24,CH05", RP01 SH09 商品综合占有率表和饼图
' "TX30,TX29,TX27,CH06,CH22", RP02 SH10 分地区综合占有率同比、环比
' "TX30,TX29,TX20,CH14", RP03 SH19 零售量比重
' "TX30,TX29,TX39,CH09", RP04 SH16 零售额比重
' "TX43,TX29,TX41,CH18", RP05 SH12 平均价格同期/上月比
'** "TX30,TX29,TX01,CH20, RP06 SH12 平均价格同期/上月比(后50名)
' "TX30,TX29,TX14,CH08", RP07 SH15 主销商场
' "TX30,TX29,TX21,CH04,CH24", RP08 SH07 品牌个月综合占有率
' "TX30,TX29,TX21,CH04,CH24", RP09 SH07 品牌个月综合占有率
' "TX30,TX29,TX21,CH04", RP10 SH07 品牌个月综合占有率
' "TX38,TX29,CH23", RP11 SH20 全国综合占有率同比
' "TX30,TX29,TX25,CH01,CH21", RP12 SH08 品牌分地区综合占有率
' "TX30,TX29,TX25,CH01,CH21", RP13 SH08 品牌分地区综合占有率
' "TX30,TX29,TX25,CH01", RP14 SH08 品牌分地区综合占有率
' "TX30,TX29,TX40,CH27", RP15 SH19 零售量比重
' "TX30,TX29,TX16,CH26", RP16 SH16 零售额比重
' "TX30,TX29,TX02,CH30", RP17 SH12 平均价格同期/上月比
'** "TX30,TX29,TX01,CH29", RP18 SH13 平均价格同期/上月比(后50名)
' "TX43,TX29,TX14,CH28", RP19 SH15 主销商场
' "TX30,TX29,TX23,CH31,TX24,CH32", RP20 SH09 商品综合占有率表和饼图
' "TX31" RP21 SH22 封面
' aRRepID=Array("RP01","RP02","RP03","RP04","RP05","RP07","RP08") 每个地区7张连续的
' aCRepID=Array("RP20","RP11","RP15","RP16","RP17","RP19") 全国6张连续的+品牌分地区TOp5
'***********************************************************************************************
Function TopSelectforPrint(j,npa)
dim cht1,cht2
TopSelectforPrint=True
Select Case j+1
Case 1 '商品综合占有率表和饼图
Set cht1=ActiveDocument.Sheets("SH09").SheetObjects("CH32")
Set cht2=ActiveDocument.Sheets("SH09").SheetObjects("CH05")
ActiveDocument.sheets("SH09").Activate
'msgbox "cht1.Attach"
if npa=0 then
cht1.Attach
cht1.Detach
else
cht2.Attach
cht2.Detach
end if
'msgbox "cht1.Detach"
Call TopMarket(20)
Case 2 '分地区综合占有率同比、环比
if npa=0 then
Call TopMarket(20)
else
Call TopMarket(10)
end if
Case 3: TopSelectforPrint= TopSaleQty(npa) '零售量
Case 4: TopSelectforPrint= TopSaleQua(npa) '零售额
Case 5
if npa=0 then
call TopPriceAveForPrint
else
TopSelectforPrint= TopPriceAve(npa) '平均价格
end if
Case 6: TopSelectforPrint= TopIndexC(npa) '主销商场
Case else
end select
end Function
sub AttachChart
dim Cht(2),i
Set cht(0)=ActiveDocument.Sheets("SH09").SheetObjects("CH32")
Set cht(1)=ActiveDocument.Sheets("SH09").SheetObjects("CH05")
Set cht(2)=ActiveDocument.Sheets("SH12").SheetObjects("CH30")
for i=0 to Ubound(Cht)
Cht(i).Attach
Next
end sub
'***********************************************************************************************
'打印品牌前5名在区域(如地区Select All代表全国)排名,
'aChts为两个table对象,aRepIds为3个打印的Item的Chart对象
Sub PrintBrandTop5(sSheetID,aChts,aRepIds)
dim i,j,FieldName,Brands,cht(1)
Call TopMarket(5)
FieldName="市场品牌名称" : Brands = GetCellsArray("CH02",0,5,1): j=0
ActiveDocument.sheets(sSheetID).Activate
Set cht(0)=ActiveDocument.Sheets(sSheetID).SheetObjects(aChts(0))
Set cht(1)=ActiveDocument.Sheets(sSheetID).SheetObjects(aChts(1))
For i=0 To Ubound(Brands)-2
ActiveDocument.Fields(FieldName).Select Brands(i)
Call UpdateChartTitle(aChts(0),Brands(i)&" 分地区市场综合占有率(%) ")
cht(0).Detach
ActiveDocument.Fields(FieldName).Select Brands(i+1)
'msgbox (i+1)&" "&Brands(i+1)
if printReport(aRepIds(j)) =false then exit sub
cht(0).Attach
i=i+1 :j=j+1
Next
Call UpdateChartTitle(aChts(0),Brands(i)&" 分地区市场综合占有率(%) ")
ActiveDocument.Fields(FieldName).Select Brands(i)
if printReport(aRepIds(j)) =false then exit sub
End Sub
'***********************************************************************************************************
'更新图表sChtID的标题为sTitle值
'***********************************************************************************************************
function UpdateChartTitle(sChtID,sTitle)
dim Graph,p
set Graph = ActiveDocument.GetSheetObject(sChtID)
set p = Graph.GetProperties
p.ChartProperties.Title.Title.v = sTitle
Graph.SetProperties p
end function
'**********************************************************************************************************
sub TopPriceAveForPrint
dim cht,atops,osf,fv,i
nTopPriceAveCount=0
Set oSf = ActiveDocument.Fields("品牌名称")
Call TopCountryPriceAve
' msgbox oSf.GetSelectedValues.Count
if oSf.GetSelectedValues.Count=100 then
nTopPriceAveCount=100
Set cht=ActiveDocument.Sheets("SH12").SheetObjects("CH30")
cht.Attach
atops=GetCellsArray("CH18",1,50,-1) '取后50名
Call TopPriceAve(50)
cht.Detach
osf.Clear
Set fv=oSf.GetNoValues
for i=0 to Ubound(atops)-1
'msgbox atops(i)
fv.Add
fv(i).text= atops(i)
fv(i).IsNumeric=false
next
oSf.SelectValues fv
end if
end sub
'**********************************************************************************************************
'**********************************************************************************************************
sub PrintIndexCRePort
dim Cht,oSf,fv,FilterIndexC,aRpIDs,val
dim RowIter,ColIter,Flag,iMin,iMax,i,j
dim table,w,h,CellMatrix
Call Lockyear(Years(0),0)
Call Lockmonth(months(0),0)
Set oSf = ActiveDocument.Fields("C指标名称")
osf.Clear
set table = ActiveDocument.GetSheetObject("CH38")
w = table.GetColumnCount
h = table.GetRowCount-1
set CellMatrix = table.GetCells2(0,1,w,h)
FilterIndexC=Array("004","005","006","007","008")
Set fv=oSf.GetNoValues
j=0
for RowIter=0 to h-1
'msgbox Trim(Cstr(CellMatrix(RowIter)(1).text))&" "&RowIter
Flag=True
val=Cstr(CellMatrix(RowIter)(0).text)
for i=0 to Ubound(FilterIndexC)-1
if val=FilterIndexC(i) then
Flag=False
Exit for
end if
next
if Flag=true then
fv.Add
fv(j).text=CellMatrix(RowIter)(1).text
fv(j).IsNumeric=false
j=j+1
end if
if Trim(Cstr(CellMatrix(RowIter)(1).text))="其他类" then
iMin=RowIter
exit for
end if
next
iMax=iMin+Cint((h-iMin+1)/2)
aRpIDs=Array("RP22","RP23","RP24")
for i=0 to 2
Select case i
case 0 : oSf.SelectValues fv
Case 1 : Call IndexCFilter(osf,CellMatrix,iMin+1,iMax)
Case 2 : Call IndexCFilter(osf,CellMatrix,iMax+1,h-1)
end select
Table.Detach
Table.Attach
call printReport(aRpIDs(i))
Next
end sub
'**********************************************************************************************************
function IndexCFilter(osf,CellMatrix,iMin,iMax)
dim RowIter,i,j,fv
j=0
osf.unlock
osf.Clear
Set fv=oSf.GetNoValues
for RowIter=iMin to iMax
fv.Add
fv(j).text=CellMatrix(RowIter)(1).text
fv(j).IsNumeric=false
j=j+1
next
oSf.SelectValues fv
osf.lock
end function
'***********************************************************************************************************
'获取字段值数组功能函数
'功能描述:读取给定字段fielename中的值赋给数组,并将其作为函数值返回
'特别说明:本函数为InitSetting()调用的一个功能函数
' 此处共有三个字段(机构,年份,月份)
'nPa 0--3 分别代表 GetSelectedValues;GetDeselectedValues;GetOptionalValues;GetExcludedValues
'----------------------------------------------------------------------------------------------------------
Function LoadSelect(fieldname,npa)
Dim Fields, i 'The Active Stage that is selected
Dim ActiveStage() 'a Array store the list of Active stage that is selected
Select Case nPa
case 0
Set Fields = ActiveDocument.Fields(fieldname).GetSelectedValues
case 1
Set Fields = ActiveDocument.Fields(fieldname).GetDeselectedValues
case 2
Set Fields = ActiveDocument.Fields(fieldname).GetOptionalValues
case 3
Set Fields = ActiveDocument.Fields(fieldname).GetExcludedValues
case 4
Set Fields = ActiveDocument.Fields(fieldname).GetpossibleValues
Case else
'LoadSelect =Null :exit function
End Select
ReDim ActiveStage(Fields.Count)
For i = 0 To Fields.Count - 1
If (Len(Fields.Item(i).Text) > 0) Then
ActiveStage(i) = Fields.Item(i).Text
'msgbox ActiveStage(i)
End If
Next
LoadSelect = ActiveStage '选中字段值数组作为函数值返回给主调函数
End Function
'***********************************************************************************************************
'获取sChtID中给定列值的前Count个值给函数数组,并将其作为函数值返回
'npa=0 Top;npa=1 Bot,当Count参数为空时,返回所有行
'TopButtom=1 为Top -1为Buttom
'----------------------------------------------------------------------------------------------------------
Function GetCellsArray(sChtId,Col,Count,TopButtom)
Dim table,CellMatrix,Values,i,w,h,iMin
set table = ActiveDocument.GetSheetObject(sChtId)
w = table.GetColumnCount
h = table.GetRowCount
set CellMatrix = table.GetCells2(0,0,w,h)
if Count="" then Count=h
if TopButtom=-1 then
iMin=h-Count-2 '有total的情况下-2,否则只需-1
else
iMin=0
end if
Redim Values(Count)
for i=0 to Count-1
Values(i)=CellMatrix(iMin+i+1)(Col).Text
next
GetCellsArray=Values
End Function
'=================================以下为和写入Word以及打开Wor报告相关函数=================================
'***********************************************************************************************************
'获取Word实例功能函数
'功能描述:获取Word Application,先检查进程中是否有Word 实例在运行,如有则将其赋给sWordApp(全局对象变量)
' 没有则试图创建Word进程,如创建失败,则将系统错误反馈给用户
'特别说明:退出时注意错误信息的清除
'----------------------------------------------------------------------------------------------------------
Function GetWordApp()
On Error Resume Next 'Resume Error
GetWordApp = True
Err.Clear
Set sWordApp = CreateObject("Word.Application") 'Create Word instance
If Err.Number <> 0 Then
MsgStr="没有获得Word 实例,请检查你您是否正确安装了Word"
GetWordApp = False
End if
End Function
'***********************************************************************************************************
'获取文件所在文件夹路径
function GetAppPath()
dim FullFileName,Pos,ShortFileName
FullFileName=ActiveDocument.GetPathName
Pos = InStrRev(FullFileName, "\", -1, 1)
GetAppPath=Left(FullFileName, Pos - 1)
'Shortfilename = Right(FullFileName, Len(FullFileName) - Pos)
end function
'***********************************************************************************************************
'文件是否存在判定功能函数
'功能描述:检查文件是否存在,传入fullfilename参数是长文件名,TypeN参数设定是否执行文件删除操作(放入回收站)
' 'Type=0 Only Check Exist,Type=1 Delete The Target File
'变量说明:file文件对象,如要查找的文件存在,则将其赋给file
' NewfileN 文件名字符串,放入回收站的文件名,其中短文件名为
file.name,文件夹为常量conRecycleFolder
'返回值 :文件存在,并根据TypeN值操作成功,返回True,文件不存在则返回false
'其他说明:文件移除亦可采用
file.name=newfilen或者file.Move(NewfileN) 语句
' 如有删除操作,将其写入日志
'----------------------------------------------------------------------------------------------------------
Function CheckFileExist(FullFileName, TypeN) 'Type=1 Delete The Target File
Dim file, NewfileN', oFSO' oFSO is the public var
If oFSO.FileExists(FullFileName) = True Then
CheckFileExist = True
If TypeN = 1 Then
Set file = oFSO.GetFile(FullFileName)
If oFSO.FileExists(NewfileN) = True Then oFSO.deletefile (NewfileN)
oFSO.movefile FullFileName, NewfileN
End If
Else
CheckFileExist = False
End If
End Function
'检查给定的路径,不存在则创建
function CheckFolder(sFoldName,TypeN)
'Type=1 Create The Target Fold,2= Delete
CheckFolder=oFSO.FolderExists(sFoldName)
if CheckFolder =false and TypeN=1 then oFSO.CreateFolder(sFoldName)
if CheckFolder =true and TypeN=2 then oFSO.deleteFolder(sFoldName)
end function
'保存Word文档前,需要检查对应的路径,不存在则创建
Sub CreateForWord
Call GetWordApp
Set oFSO=CreateObject("Scripting.FileSystemObject")
sFold=GetAppPath&"\QReport"
sYMFolder=sFold&"\"&YearMonth
sRecycleFolder=sFold&"\QRecycle"
Call CheckFolder(sFold,1)
Call CheckFolder(sYMFolder,1)
Call CheckFolder(sRecycleFolder,1)
end Sub
'退出Word Application
Sub QuitWord
sWordApp.Quit
Set oFSO=Nothing
Set oWordDoc=Nothing
Set sWordApp=Nothing
end Sub
'将oDoc文档保存到路径fullfilename
Sub SaveWord(oDoc,fullfilename)
Dim t,WordSelection
For Each t In oDoc.Tables
t.select
Set WordSelection=sWordApp.Selection
with WordSelection
.tables(1).AutoFitBehavior wdAutoFitWindow 'auto fit
.Rows.AllowBreakAcrossPages = True 'Break Page
.Rows(1).HeadingFormat = True 'the Same Heading For table in each page
end with
Next
'msgbox fullfilename
Call CheckFileExist(fullfilename,1)
oDoc.SaveAS(fullfilename)
oDoc.Close
end sub
'将报表中sRepId中的所有对象写入Word文档
function WriteToWord(oWordDoc,sRepID)
dim WordSelection,acht,item,i,j,Count
'Call GetWordApp
'Set NewWordDoc = sWordApp.Documents.Add
Set WordSelection=sWordApp.Selection
if mid(sRepID,3,1)="0" then
item=right(sRepId,1)
else
item=right(sRepId,2)
end if
item=item-1
acht=split(aChts(item),",")
for i=0 to ubound(acht)
'msgbox acht(i) &" "&i '信息提示
if UpdateClipboard(acht(i)) then
'WordSelection.Font.Bold = True
'WordSelection.Font.Size = "18"
WordSelection.Paste
'WordSelection.PasteAndFormat (wdPasteDefault)
else
end if
select case acht(i)
case "CH01","CH04","CH06"
Count=4
case else
Count=1
end select
for j=1 to Count
WordSelection.TypeParagraph
next
next
'WordSelection.InsertNewPage
WordSelection.InsertBreak wdPageBreak
end function
'将sChtID图表中的信息导出到Clipboard
function UpdateClipboard(sChtId)
dim obj,typeN
UpdateClipboard=true
set obj=activedocument.getsheetobject(sChtId)
typeN=obj.getobjecttype
select case typeN
case 6 'text object
if len(obj.getproperties.layout.text.v)>0 then
obj.CopyTextToClipboard
else
UpdateClipboard=false
end if
Case 10,11 '10=Pivot Table,11=Straight Table
obj.CopyTableToClipboard true
case 12,13,14,15,16,17,20,21,22 'copy image,不能用is< 和 1 to 5 etc..
obj.CopyBitmapToClipboard
case else
obj.CopyBitmapToClipboard 'others case: don't copy
end select
'Add Code for Select Copy,et:copy table or copy value ,or copy image
'**copy selection stamp of active document **
'ActiveDocument.CopyCurrentSelectionsToClipboard
end function
'***********************************************************************************************************
'根据选择的产品子类名称,年份,月份值,批量打开对应的报告文档(Word)
'***********************************************************************************************************
sub GetFileForOpen
ErrStr=Null
dim fullfilename,i,Count,LostFileList
Products=LoadSelect("产品子类产品名称",0) :Years=LoadSelect("年",0):Months=Loadselect("月",0)
YearMonth=Years(0)&"年"&Months(0)&"月"
if Ubound(years)*Ubound(Months)*Ubound(Products)=0 or Ubound(Months)>1 Then
Call ReturnMsg("年.月.产品字段漏选或多选,请重新选择",32,0)
Exit Sub
end if
Call GetWordApp
Set oFSO=CreateObject("Scripting.FileSystemObject")
sFold=GetAppPath&"\QReport"
sFold=sFold&"\"&YearMonth&"\"&YearMonth
for i=0 to ubound(Products)-1
fullfilename=sFold&Products(i)&".doc"
if CheckFileExist(fullfilename,0) then
Call OpenWordDoc(fullfilename)
else
count=count+1
LostFileList=LostFileList&YearMonth&Products(i)&Chr(10)
end if
next
if len(LostFileList)>0 then ReturnMsg "如下月类别尚未生成电子文档: "&chr(10)&chr(10)&LostFileList,64,0
if count=i then sWordApp.Quit
end sub
'打开长文件名称为fullfilename的Word文档
sub OpenWordDoc(fullfilename)
'Call GetWordApp
sWordApp.Visible=true
sWordApp.Documents.Open fullfilename
end sub
'=========================以下为公共的函数模块=================================
'*********************************************************************************************************
function Gettime()
Gettime=cstr(now)
end function
'***********************************************************************************************************
'自定义信息反馈处理函数
'功能描述:执行Msgbox 函数,当TypeN=1是返回用户选择值
'参数说明:InfN为系统界面参数;TypeN为是否需要返回值(1是0否)
' InfN参数设定为 vbYesNo 4 显示是和否按钮。
' vbCritical 16 显示临界信息图标。
' vbQuestion 32 显示警告查询图标。
' vbExclamation 48 显示警告消息图标。
' vbInformation 64 显示信息消息图标。
'返回值: vbIgnore 5 忽略 ; vbYes 6 是 ; vbNo 7 否
'改进:可添加参数计算代码,并根据参数判定是否需要返回函数值,可减少TypeN参数传入
'----------------------------------------------------------------------------------------------------------
Function ReturnMsg(Str, InfN, TypeN)
If TypeN = 1 Then
ReturnMsg = MsgBox(Str, InfN, "操作信息")
Else
if Err.Number=500 then
exit function
elseif len(Str)=0 then
Str="系统遇到异常情况,请退出所有程序后再试"
Call MsgBox (Str, InfN, "信息提示")
else
Call MsgBox (Str, InfN, "信息提示")
end if
End If
End Function
'***********************************************************************************************************
'功能:清空保存的历史数据
'----------------------------------------------------------------------------------------------------------
Sub ReloadData()
if ReturnMsg("确定要重新加载所有数据吗?",36,1)=6 then
Activedocument.Reload 2
end if
End Sub
sub GetPrintType
dim TypeN
TypeN=LoadSelect("打印方式",0)'Allways one select
Call UpdateVarValue("PrintTypeN",TypeN(0))
end sub
''********************************************************************************************
''获取sCht中首列中的Total值,将其赋给变量RowCount,并将其作为函数值返回
''备注:此处首列total必须设为total Count
''********************************************************************************************
'function GetTopNum(sCht)
' Call GetUpdateVar("品牌名称",sCht,0,"RowCount")
' GetTopNum=GetVarValue("RowCount")
'end function
''********************************************************************************************
''获取sCht中首列中的Total值,将其赋给变量RowCount,并将其作为函数值返回
''备注:此处首列total必须设为total Count
''与函数GetTopNum的区别在于去除了尾列数值为0的行
''********************************************************************************************
'function GetTopNum2(sCht)
' Call GetUpdateVar("品牌名称",sCht,0,"RowCount")
' dim Num,LastRowValue
' Num=GetVarValue("RowCount")
' LastRowValue= GetTableValue(sCht,2,2)
' 'LastRowValue=GetVarValue("LastRowValue")
' if LastRowValue=0 then Num=Num-1
' GetTopNum2=Num
'end function
'===================================以下为测试代码========================================
sub atest
dim aArea,aTemp
aArea=LoadSelect("打印区域",0)
aTemp=Array(aArea(0))
msgbox Ubound(aTemp)&" "&atemp(0)
'aArea=Array("东北")
'aArea=Array("华北","东北","华东","中南","西南","西北")
msgbox Ubound(aArea)&" "&aArea(0)&""&aArea(1)
end sub
