home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Programming Languages Suite
/
ProgramD2.iso
/
Visual Database
/
Visual Foxpro 6.0 (Ent. Edition)
/
Vf6ent Extractor.EXE
/
TOOLS
/
ADDLABEL
/
ADDLABEL.APP
(
.txt
)
next >
Encoding:
Amiga
Atari
Commodore
DOS
FM Towns/JPY
Macintosh
Macintosh JP
Macintosh to JP
NeXTSTEP
RISC OS/Acorn
Shift JIS
UTF-8
Wrap
MS Visual FoxPro App
|
1998-05-26
|
140.0 KB
|
2,447 lines
PLATFORM
UNIQUEID
TIMESTAMP
CLASS
CLASSLOC
BASECLASS
OBJNAME
PARENT
PROPERTIES
PROTECTED
METHODS
OBJCODE
RESERVED1
RESERVED2
RESERVED3
RESERVED4
RESERVED5
RESERVED6
RESERVED7
RESERVED8
COMMENT Screen
WINDOWS _QTS0I9HEP 546203848
WINDOWS _QTR0X0BGR 606638154
WINDOWS _QTS0I9HEP 546244022
WINDOWS _QTS0I9HEP 551043836N
WINDOWS _R9L06FHTB 579769148
WINDOWS _R9L06FHUA 606638154
WINDOWS _R9L18TP16 579770109
WINDOWS _QTS0I9HEP 591747627
WINDOWS _R9L1DGFDH 591747627
WINDOWS _R9L1DGFE2 591747627`
WINDOWS _RJR12MGOY 579768358
COMMENT RESERVED
VERSION = 3.00
dataenvironment
dataenvironment
Datanavigation
ILeft = 1
Top = 220
Width = 520
Height = 120
Name = "Datanavigation"
form1
DataSession = 2
ScaleMode = 3
Height = 215
Width = 447
DoCreate = .T.
AutoCenter = .T.
BorderStyle = 2
Caption = "Custom Labels"
MaxButton = .F.
MinButton = .F.
WindowType = 1
WindowState = 0
Name = "form1"
PROCEDURE deletelabel
#DEFINE LBLREGKEY1 "Software\Microsoft\VisualFoxPro\"
#DEFINE LBLREGKEY2 "\Labels"
#DEFINE HKEY_CURRENT_USER -2147483647 && BITSET(0,31)+1
LPARAMETERS cLblName
LOCAL nRetCode, cLblRegKey
cLblRegKey = LBLREGKEY1 + _VFP.Version + LBLREGKEY2
* Need to remove Registry entry if any
m.cLblName= ALLTRIM(m.cLblName) + CHR(0)
nRetCode = THISFORM.oRegistry.DeleteKeyValue(m.cLblName, m.cLblRegKey, HKEY_CURRENT_USER)
ENDPROC
PROCEDURE Destroy
LOCAL tmpF1
IF EMPTY(THIS.OldF1)
ON KEY LABEL F1
tmpF1 = THIS.OldF1
ON KEY LABEL F1 &tmpF1
ENDIF
ENDPROC
PROCEDURE Refresh
IF THIS.lstLabels.ListCount = 0
THIS.cmdDelete.Enabled = .F.
THIS.cmdEdit.Enabled = .F.
THIS.cmdEdit.Enabled = .T.
THIS.cmdDelete.Enabled = .T.
ENDIF
ENDPROC
PROCEDURE Init
#DEFINE USERLBLS_LOC "userlbls.dbf"
#DEFINE LBLSPATH_LOC "Tools\AddLabel\"
#DEFINE cWhere_loc "Where is "+USERLBLS_LOC+"?"
#DEFINE cFILEINUSE_LOC "Could not open Userlbls table. Check to see if this table is in use by another."
LOCAL cLblsFile,aDirArray,nDirs
DIME aDirArray[1]
SET DELETED ON
SET EXCLUSIVE ON
DO CASE
CASE FILE(USERLBLS_LOC)
*This.label_file = "labels"
cLblsFile = USERLBLS_LOC
CASE FILE(HOME()+USERLBLS_LOC)
cLblsFile = HOME()+USERLBLS_LOC
CASE FILE(HOME()+LBLSPATH_LOC+USERLBLS_LOC)
cLblsFile = HOME()+LBLSPATH_LOC+USERLBLS_LOC
OTHERWISE
cLblsFile = ""
ENDCASE
IF EMPTY(m.cLblsFile)
* Create a new one
nDirs = ADIR(aDirArray,HOME()+LBLSPATH_LOC,"D")
IF m.nDirs # 0
cLblsFile = HOME()+LBLSPATH_LOC+USERLBLS_LOC
ELSE
cLblsFile = HOME()+USERLBLS_LOC
ENDIF
CREATE TABLE (m.cLblsFile) ;
(TYPE c(12),;
ID c(12),;
NAME c(24),;
READONLY L,;
CKVAL N(6),;
DATA M,;
UPDATED D)
* This.label_file = GETFILE("DBF",cWhere_loc)
USE (m.cLblsFile) ALIAS userlbls
ENDIF
IF EMPTY(ALIAS())
* We had an error opening file, may be in use.
* Try opening it shared
USE (m.cLblsFile) ALIAS userlbls SHARED
IF EMPTY(ALIAS())
= MESSAGEBOX(cFILEINUSE_LOC)
RETURN .F.
ENDIF
This.label_file = ALIAS()
ENDIF
SELECT 0
CREATE CURSOR WzLabels ;
(Name C(30),;
LblDimen C(40),;
LblColumns C(2),;
Data M)
SELECT userlbls
SCAN FOR ID="LABELLYT" AND !DELETED()
INSERT INTO WzLabels (Name, LblDimen, LblColumns,Data);
VALUE (userlbls.Name,;
ALLTRIM(SUBSTR(userlbls.Data,15,11))+" x "+ALLTRIM(SUBSTR(userlbls.Data, 26, 11)), ;
ALLTRIM(SUBSTR(userlbls.Data, 37, 2)),;
userlbls.Data)
ENDSCAN
SELECT wzlabels
THIS.lstLabels.RowSource = "Name, LblDimen, LblColumns"
THIS.lstLabels.Value = 1
THIS.lstLabels.ColumnWidths = "120,140,130"
THIS.OldF1 = ON("KEY","F1")
ON KEY LABEL F1 HELP ID 489321235
THISFORM.REFRESH
ENDPROC
NewLabel
CSAVENAME
NEWLABEL
USERLBLS
THISFORM
DELETELABEL
WZLABELS
LSTLABELS
SETFOCUS
REFRESH
Click,
Are you sure you want to delete the label?
CNAME
CREGNAME
THISFORM
LSTLABELS
LISTCOUNT
USERLBLS
WZLABELS
DELETELABEL
SETFOCUS
REFRESH
Click,
THISFORM
CMDEDIT
CLICK
DblClick,
USERLBLS
THISFORM
RELEASE
Click,
NewLabel
NEWLABEL
WZLABELS
THISFORM
LSTLABELS
SETFOCUS
REFRESH
Click,
JArial, 0, 9, 5, 15, 12, 21, 3, 0
MS Sans Serif, 0, 8, 5, 13, 11, 11, 2, 0
DTop = 180
Left = 408
Height = 17
Width = 20
Name = "oRegistry"
form1
oRegistry
custom
..\wzcommon\registry.vcx
registry
FontName = "MS Sans Serif"
FontSize = 8
BackStyle = 0
Caption = "Columns"
Height = 15
Left = 280
Top = 12
Width = 69
Name = "Label3"
form1
Label3
label
label
form1
Label2
label
label
form1
"label_file
oldf1
*deletelabel
commandbutton
commandbutton
cmdNew
form1
Top = 110
Left = 364
Height = 23
Width = 72
FontName = "MS Sans Serif"
FontSize = 8
Caption = "\<New..."
TabIndex = 3
Name = "cmdNew"
lPROCEDURE Click
DO FORM NewLabel
SELECT wzlabels
THISFORM.lstLabels.SetFocus
THISFORM.Refresh
ENDPROC
FontName = "MS Sans Serif"
FontSize = 8
BackStyle = 0
Caption = "Dimensions"
Height = 15
Left = 138
Top = 12
Width = 87
Name = "Label2"
Label1
label
label
form1
cmdEdit
commandbutton
commandbutton
form1
cmdDelete
commandbutton
commandbutton
cmdClose
form1
Top = 32
Left = 364
Height = 23
Width = 72
FontName = "MS Sans Serif"
FontSize = 8
Cancel = .T.
Caption = "Close"
TabIndex = 5
Name = "cmdClose"
PROCEDURE Click
SELECT userlbls
IF ISEXCL()
* Perform a little maintenance
LOCATE FOR DELETED()
IF FOUND()
PACK
PACK MEMO
ENDIF
ENDIF
THISFORM.RELEASE
ENDPROC
FontName = "MS Sans Serif"
FontSize = 8
BackStyle = 0
Caption = "Name"
Height = 15
Left = 14
Top = 12
Width = 50
Name = "Label1"
commandbutton
commandbutton
7PROCEDURE DblClick
THISFORM.cmdEdit.Click()
ENDPROC
form1
lstLabels
listbox
listbox
FontName = "MS Sans Serif"
FontSize = 8
ColumnCount = 3
RowSourceType = 6
Height = 170
Left = 12
TabIndex = 4
Top = 31
Width = 337
Name = "lstLabels"
/PROCEDURE Click
LOCAL cSaveName
cSaveName = ALLTRIM(Name)
DO FORM NewLabel WITH .T.
* Check to see if name changed
SELECT userlbls
IF !UPPER(m.cSaveName) == UPPER(ALLTRIM(Name))
THISFORM.DeleteLabel(m.cSaveName)
ENDIF
SELECT wzlabels
THISFORM.lstLabels.SetFocus
THISFORM.Refresh
ENDPROC
Top = 84
Left = 364
Height = 23
Width = 72
FontName = "MS Sans Serif"
FontSize = 8
Caption = "\<Delete"
TabIndex = 2
Name = "cmdDelete"
PROCEDURE Click
#DEFINE CDELETE_LOC "Are you sure you want to delete the label?"
LOCAL cName, cRegName
IF THISFORM.lstLabels.Listcount = 0 OR MESSAGEBOX(CDELETE_LOC,36) # 6
RETURN
ENDIF
cName = UPPER(ALLTRIM(Name))
cRegName = Name
SELECT userlbls
LOCATE FOR UPPER(ALLTRIM(Name))==m.cName AND !DELETED()
IF FOUND()
DELETE
ENDIF
SELECT wzlabels
DELETE
THISFORM.DeleteLabel(m.cRegName) &&removes from registry
THISFORM.lstlabels.SetFocus
THISFORM.REFRESH
ENDPROC
Top = 58
Left = 364
Height = 23
Width = 72
FontName = "MS Sans Serif"
FontSize = 8
Caption = "\<Edit..."
TabIndex = 1
Name = "cmdEdit"
Software\Microsoft\VisualFoxPro\
\Labels
CLBLNAME
NRETCODE
CLBLREGKEY
VERSION
THISFORM
OREGISTRY
DELETEKEYVALUE`
ON KEY LABEL F1 &tmpF1
TMPF1
OLDF1
THIS
LSTLABELS
LISTCOUNT
CMDDELETE
ENABLED
CMDEDIT
userlbls.dbf0
userlbls.dbf
userlbls.dbf
userlbls.dbf
Tools\AddLabel\
userlbls.dbf
Tools\AddLabel\
userlbls.dbf
Tools\AddLabel\
Tools\AddLabel\
userlbls.dbf
userlbls.dbf
Could not open Userlbls table. Check to see if this table is in use by another.
WzLabels
LABELLYT
WzLabels
Name, LblDimen, LblColumns
120,140,130
HELP ID 489321235
CLBLSFILE
ADIRARRAY
NDIRS
READONLY
CKVAL
UPDATED
USERLBLS
LABEL_FILE
WZLABELS
LBLDIMEN
LBLCOLUMNS
LSTLABELS
ROWSOURCE
VALUE
COLUMNWIDTHS
OLDF1
THISFORM
REFRESH
deletelabel,
Destroy
Refresh
Init3
d:\8146\fox60\xpieces\addlabel\addlabel.scx
PLATFORM
UNIQUEID
TIMESTAMP
CLASS
CLASSLOC
BASECLASS
OBJNAME
PARENT
PROPERTIES
PROTECTED
METHODS
OBJCODE
RESERVED1
RESERVED2
RESERVED3
RESERVED4
RESERVED5
RESERVED6
RESERVED7
RESERVED8
COMMENT Screen
WINDOWS _R8T13G40P 544314328
WINDOWS _R8T13G40X 591748010
WINDOWS _R8T13G40P 551043889
WINDOWS _R8T13G43F 579768625
WINDOWS _R8T13G40P 551043616
WINDOWS _R8T13G45X 591746850
WINDOWS _R8T13G472 591746850
WINDOWS _R9K15742G 546151933
WINDOWS _R9K15742W 591746850
WINDOWS _R9K15743C 546182489$D
WINDOWS _R9K157446 591746850ME
WINDOWS _R8T13G40P 546220955wF
WINDOWS _R9K15745P 546182489xJ
WINDOWS _R9K15746I 546182489
WINDOWS _R8T13G40P 591748010
WINDOWS _R9K15747V 591746850
WINDOWS _R8T13G40P 546182151
WINDOWS _R8T13G40P 591746850l;
WINDOWS _R9K163WGW 546153523|:
WINDOWS _R9K163WHK 551043616
WINDOWS _R9L05FSRW 591746850x8
WINDOWS _RJR12X8YO 579768626"
COMMENT RESERVED
VERSION = 3.00
dataenvironment
dataenvironment
Dataenvironment
Name = "Dataenvironment"
form1
Height = 364
Width = 500
DoCreate = .T.
AutoCenter = .T.
BorderStyle = 2
Caption = "New Label Definition"
MaxButton = .F.
MinButton = .F.
WindowType = 1
WindowState = 0
LockScreen = .F.
lenglish = .T.
cchangevalue = ("")
Name = "form1"
dPROCEDURE convertmm
LPARAMETER cInValue,lwhichway
* Converts metric values entered in millimeters to 10,000ths of an inch.
LOCAL nInValue,cOutValue
*!* nInValue = VAL(ALLTRIM(m.cInValue))
m.nInValue = m.cInValue
IF !m.lwhichway
* metric to english
nInValue = ROUND(((m.nInValue*39.3700787402E-2)),4)
* english to metric
nInValue = ROUND(((m.nInValue/39.3700787402E-2)),4)
ENDIF
*!* cOutValue = ALLTRIM(STR(m.nInValue,8,3))
RETURN m.nInValue
ENDPROC
PROCEDURE resetlabel
#DEFINE ENGMEASURE '"'
#DEFINE METMEASURE 'cm'
#DEFINE ENGPROMPT_LOC "Enter label measurements in inches:"
#DEFINE METPROMPT_LOC "Enter label measurements in centimeters:"
#DEFINE CMDADDCAP_LOC "\<Update"
LOCAL cLblData,cDesc,cDelim,cDataDesc
cLblData = ALLTRIM(Data)
THIS.cmdAdd.Caption = CMDADDCAP_LOC
This.LayoutName.Value = Name
This.ogpMetric.Value = IIF(RIGHT(m.cLblData,1)="T",2,1)
IF This.ogpMetric.Value = 2
This.LblPrompt.Caption = METPROMPT_LOC
ENDIF
cDelim=IIF(This.ogpMetric.Value = 2,METMEASURE,ENGMEASURE)
This.LeftMargin.Value= VAL(SUBSTR(m.cLblData,40,8))/10000
This.NumberAcross.Value= VAL(SUBSTR(m.cLblData,48,2))
This.SpacesBetween.Value= VAL(SUBSTR(m.cLblData,50,8))/10000
This.LabelWidth.Value= VAL(SUBSTR(m.cLblData,58,8))/10000
This.TopMargin.Value= VAL(SUBSTR(m.cLblData,66,8))/10000
This.LabelHeight.Value = VAL(SUBSTR(m.cLblData,74,8))/10000
IF This.ogpMetric.Value = 2
* If the values are metric, convert them to english
This.LeftMargin.Value= ThisForm.ConvertMM(This.LeftMargin.Value,.T.)
This.SpacesBetween.Value= ThisForm.ConvertMM(This.SpacesBetween.Value,.T.)
This.LabelWidth.Value= ThisForm.ConvertMM(This.LabelWidth.Value,.T.)
This.TopMargin.Value= ThisForm.ConvertMM(This.TopMargin.Value,.T.)
This.LabelHeight.Value= ThisForm.ConvertMM(This.LabelHeight.Value,.T.)
ENDIF
m.cDesc = PADR(LEFT(ALLTRIM(This.LayoutName.Value),11),11)+ " "
m.cDesc = m.cDesc + PADR(ALLTRIM(STR(This.LabelHeight.Value,8,2))+m.cDelim,11)
m.cDesc = m.cDesc + PADR(ALLTRIM(STR(This.LabelWidth.Value,8,2))+m.cDelim,11)
m.cDesc = m.cDesc + PADL(ALLTRIM(STR(This.NumberAcross.Value)),2," ")+" "
cDataDesc = ALLTRIM(SUBSTR(data,3,37))
cDesc = ALLTRIM(m.cDesc)
THIS.lChangeDesc = (m.cDataDesc#m.cDesc)
IF THIS.lChangeDesc
LOCAL cPart1,cPart2
cPart1 = ALLTRIM(SUBSTR(m.cDataDesc,11,11))
cPart2 = ALLTRIM(SUBSTR(m.cDataDesc,22,11))
cPart1 = m.cPart1+" x "+m.cPart2
THIS.Description.Value = m.cPart1
THIS.Description.Enabled = .T.
THIS.chkSet.Value = 1
THIS.cChangeValue = m.cPart1
IF This.ogpMetric.Value = 2
m.cDelim = " "+m.cDelim
ENDIF
This.Description.Value = ALLT(STR(This.LabelHeight.Value,8,2))+;
m.cDelim+" x "+ALLT(STR(This.LabelWidth.Value,8,2))+m.cDelim
ENDIF
THISFORM.REFRESH
ENDPROC
PROCEDURE labeltoregistry
#DEFINE LBLREGKEY1 "Software\Microsoft\VisualFoxPro\"
#DEFINE LBLREGKEY2 "\Labels"
#DEFINE HKEY_CURRENT_USER -2147483647 && BITSET(0,31)+1
#DEFINE NOREGWRITE_LOC "Could not write labels to Registry."
#DEFINE UPDATEREG_LOC "Updating Registry with label definitions..."
LOCAL nRetCode,nSaveArea,cGetName,cGetData,cLblRegKey
cLblRegKey = LBLREGKEY1 + _VFP.Version + LBLREGKEY2
nRetCode = THIS.oRegistry.OpenKey(m.cLblRegKey, HKEY_CURRENT_USER, .T.)
IF nRetCode #0
MESSAGEBOX(NOREGWRITE_LOC)
RETURN
ENDIF
nRetCode = THIS.oRegistry.CloseKey()
WAIT WINDOW UPDATEREG_LOC NOWAIT
nRetCode = 0
m.cGetName = ALLTRIM(name)
m.cGetData = ALLTRIM(SUBST(data,3))
m.nRetCode = THIS.oRegistry.SetRegKey(m.cGetName ,m.cGetData , m.cLblRegKey, HKEY_CURRENT_USER)
IF m.nRetCode#0
=MESSAGEBOX(NOREGWRITE_LOC)
EXIT
ENDIF
ENDSCAN
WAIT CLEAR
ENDPROC
PROCEDURE Init
PARAMETER lEditMode
IF TYPE("m.lEditMode")="L" AND m.lEditMode
* Edit record - if we ever add support for this
THIS.EditMode = 1
THIS.ResetLabel
* Add record
THIS.EditMode = 0
ENDIF
ENDPROC
THISFORM
DESCRIPTION
ENABLED
VALUE
LCHANGEDESC
CDELIM
CSAVEVALUE
OGPMETRIC
LABELHEIGHT
LABELWIDTH
CCHANGEVALUE
SETFOCUS
Click,
Enter label measurements in inches:
Enter label measurements in centimeters:
CDELIM
VALUE
THISFORM
LENGLISH
LBLPROMPT
CAPTION
LEFTMARGIN
CONVERTMM
SPACESBETWEEN
LABELWIDTH
TOPMARGIN
LABELHEIGHT
DESCRIPTION
LCHANGEDESC
REFRESH
Click,
VALUE
Init,
THISFORM
LCHANGEDESC
CDELIM
OGPMETRIC
VALUE
DESCRIPTION
LABELHEIGHT
LABELWIDTH
LostFocus,
THISFORM
RELEASE
Click,
JArial, 0, 9, 5, 15, 12, 13, 3, 0
MS Sans Serif, 0, 8, 5, 13, 11, 11, 2, 0
CTop = 98
Left = 399
Height = 17
Width = 33
Name = "oRegistry"
form1
oRegistry
custom
ilabel_file
lenglish
lchangedesc
editmode
cchangevalue
*convertmm
*resetlabel
*labeltoregistry
commandbutton
commandbutton
cmdCancel
form1
Top = 38
Left = 408
Height = 23
Width = 72
FontName = "MS Sans Serif"
FontSize = 8
Cancel = .T.
Caption = "Cancel"
TabIndex = 11
Name = "cmdCancel"
,PROCEDURE Click
THISFORM.RELEASE
ENDPROC
..\wzcommon\registry.vcx
registry
}Top = 42
Left = 360
Height = 17
Width = 36
FontName = "MS Sans Serif"
FontSize = 8
Caption = "\<Set"
Name = "chkSet"
form1
chkSet
commandbutton
commandbutton
cmdAdd
form1
Top = 10
Left = 408
Height = 23
Width = 72
FontName = "MS Sans Serif"
FontSize = 8
Caption = "\<Add"
Default = .T.
TabIndex = 10
Name = "cmdAdd"
aPROCEDURE Click
#DEFINE cMess1_loc 'Please supply a value for Label Name'
#DEFINE cMess2_loc 'Please supply a value for Description'
#DEFINE cMess3_loc 'Please supply a value for Left Margin'
#DEFINE cMess4_loc 'Please supply a value for Label Height'
#DEFINE cMess5_loc 'Please supply a value for Number Across'
#DEFINE cMess6_loc 'Please supply a value for Top Margin'
#DEFINE cMess7_loc 'Please supply a value for Label Width'
#DEFINE cMess8_loc 'Please supply a value for Space Between'
#DEFINE cMess9_loc 'New Label Layout successfully added to labels file and registry.'
#DEFINE cMess10_loc 'The new label layout could not be added. Make sure you have Labels file.'
#DEFINE cDupeLbL_LOC "A label with the same name already exists, would you like to replace it?"
LOCAL nLeftMarg, nSpace, nLblWid, nTopMarg
LOCAL nLblHgt, cDataFld, cDesc, cDelim
LOCAL lExists, cSaveName
DO CASE
CASE EMPTY(ThisForm.LayoutName.Value)
=messagebox(cMess1_loc)
ThisForm.LayoutName.SetFocus
RETURN
CASE EMPTY(ThisForm.LabelHeight.Value)
=messagebox(cMess4_loc)
ThisForm.LabelHeight.SetFocus
RETURN
CASE EMPTY(ThisForm.LabelWidth.Value)
=messagebox(cMess7_loc)
ThisForm.LabelWidth.SetFocus
RETURN
CASE EMPTY(ThisForm.NumberAcross.Value)
=messagebox(cMess5_loc)
ThisForm.LabelWidth.SetFocus
RETURN
ENDCASE
m.cSaveName = ""
SELECT userlbls
* Add mode only
IF THISFORM.EditMode = 0
LOCATE FOR UPPER(ALLTRIM(name)) == UPPER(ALLTRIM(THISFORM.LayOutName.Value));
AND !DELETE()
IF FOUND()
IF MESSAGEBOX(cDupeLbL_LOC,36)#6
RETURN
ENDIF
m.lExists = .T.
m.cSaveName = THISFORM.LayOutName.Value
ENDIF
* Edit mode
m.cSaveName = WzLabels.Name
LOCATE FOR UPPER(ALLTRIM(name)) == UPPER(ALLTRIM(m.cSaveName));
AND !DELETE()
m.lExists = .T.
ENDIF
nLeftMarg = ThisForm.LeftMargin.Value
nSpace = ThisForm.SpacesBetween.Value
nLblWid = ThisForm.LabelWidth.Value
nTopMarg = ThisForm.TopMargin.Value
nLblHgt = ThisForm.LabelHeight.Value
IF (ThisForm.ogpMetric.Value = 2)
* If the values are metric, convert them to english
nLeftMarg = ThisForm.ConvertMM(m.nLeftMarg)
nSpace = ThisForm.ConvertMM(m.nSpace)
nLblWid = ThisForm.ConvertMM(m.nLblWid)
nTopMarg = ThisForm.ConvertMM(m.nTopMarg)
nLblHgt = ThisForm.ConvertMM(m.nLblHgt)
ENDIF
* Convert to 1/10000 of an inch for report writer
nLeftMarg = ALLTRIM(STR(ROUND(m.nLeftMarg,5) * 10000))
nSpace = ALLTRIM(STR(ROUND(m.nSpace,5) * 10000))
nLblWid = ALLTRIM(STR(ROUND(m.nLblWid,5) * 10000))
nTopMarg = ALLTRIM(STR(ROUND(m.nTopMarg,5) * 10000))
nLblHgt = ALLTRIM(STR(ROUND(m.nLblHgt,5) * 10000))
m.cDelim = IIF(THISFORM.ogpMetric.Value=1,'"','cm')
m.cDesc = PADR(LEFT(ALLTRIM(ThisForm.LayoutName.Value),11),11)+ " "
IF THISFORM.lChangeDesc
LOCAL nSepPos,cPart1,cPart2,cTmpStr
cTmpStr = LEFT(ALLTRIM(ThisForm.Description.Value),22)
nSepPos = ATC("X",m.cTmpStr)
IF nSepPos #0
cPart1 = PADR(SUBSTR(cTmpStr,1,nSepPos-1),11)
cPart2 = PADR(ALLTRIM(SUBSTR(cTmpStr,nSepPos+1)),11)
m.cDesc = m.cDesc + m.cPart1 + m.cPart2
ELSE
* No separator, so we can't parse
THISFORM.lChangeDesc = .F.
ENDIF
ENDIF
IF !THISFORM.lChangeDesc
m.cDesc = m.cDesc + PADR(ALLTRIM(STR(ThisForm.LabelHeight.Value,8,2))+m.cDelim,11)
m.cDesc = m.cDesc + PADR(ALLTRIM(STR(ThisForm.LabelWidth.Value,8,2))+m.cDelim,11)
ENDIF
m.cDesc = m.cDesc + PADL(ALLTRIM(STR(ThisForm.NumberAcross.Value)),2," ")+" "
m.cDataFld = CHR(4)+CHR(0) + m.cDesc + ;
PADL(m.nLeftMarg,8,"0") + ;
PADL(ALLTRIM(STR(ThisForm.NumberAcross.Value)),2,"0") + ;
PADL(m.nSpace,8,"0") + ;
PADL(m.nLblWid,8,"0") + ;
PADL(m.nTopMarg,8,"0") + ;
PADL(m.nLblHgt,8,"0") + ;
IIF(ThisForm.ogpMetric.Value#1,'T','F')
IF m.lExists
REPLACE Name WITH ThisForm.LayoutName.Value,;
Ckval WITH VAL(SYS(2007,SUBSTR(m.cDataFld,3))),;
Data WITH m.cDataFld
SELECT wzlabels
LOCATE FOR UPPER(ALLTRIM(name)) == UPPER(ALLTRIM(m.cSaveName)) AND !DELETE()
IF FOUND()
REPLACE Name WITH ThisForm.LayoutName.Value,;
LblDimen WITH ALLT(SUBSTR(userlbls.Data,15,11))+" x "+ALLT(SUBSTR(userlbls.Data,26,11)),;
LblColumns WITH ALLT(SUBSTR(userlbls.Data,37,2)),;
Data WITH m.cDataFld
ENDIF
INSERT INTO userlbls VALUES;
('DATAW','LABELLYT' ,ThisForm.LayoutName.Value,.F.,;
VAL(SYS(2007, SUBSTR(m.cDataFld,3))),m.cDataFld,{})
INSERT INTO WzLabels (Name, LblDimen, LblColumns, Data);
VALUE (userlbls.Name,;
ALLTRIM(SUBSTR(userlbls.Data,15,11))+" x "+ALLTRIM(SUBSTR(userlbls.Data,26,11)), ;
ALLTRIM(SUBSTR(userlbls.Data,37,2)),userlbls.Data)
ENDIF
THISFORM.labeltoregistry
WAIT WINDOW cMess9_loc TIMEOUT 1
THISFORM.RELEASE
ENDPROC
THISFORM
LCHANGEDESC
CDELIM
OGPMETRIC
VALUE
DESCRIPTION
LABELHEIGHT
LABELWIDTH
LostFocus,
PROCEDURE Click
THISFORM.Description.Enabled = (THIS.Value=1)
THISFORM.lChangeDesc = (THIS.Value=1)
IF THIS.Value # 1
LOCAL cDelim,cSaveValue
cSaveValue = ALLTRIM(ThisForm.Description.Value)
m.cDelim = IIF(THISFORM.ogpMetric.Value=1,'"',' cm')
ThisForm.Description.Value = ALLTRIM(STR(ThisForm.LabelHeight.Value,8,2))+;
m.cDelim+" x "+ALLTRIM(STR(ThisForm.LabelWidth.Value,8,2))+m.cDelim
IF ALLTRIM(ThisForm.Description.Value)#m.cSaveValue
THISFORM.cChangeValue = m.cSaveValue
ENDIF
IF !EMPTY(THISFORM.cChangeValue)
ThisForm.Description.Value = THISFORM.cChangeValue
ENDIF
THISFORM.Description.SetFocus()
ENDIF
ENDPROC
checkbox
checkbox
AutoSize = .T.
FontName = "MS Sans Serif"
FontSize = 8
BackStyle = 0
Caption = "Dimensions:"
Height = 15
Left = 14
Top = 44
Width = 59
TabIndex = 0
BackColor = 192,192,192
Name = "Label8"
form1
Label8
label
label
FontName = "MS Sans Serif"
FontSize = 8
BackStyle = 1
Caption = "Enter label measurements in inches:"
Height = 15
Left = 14
Top = 135
Width = 217
TabIndex = 0
Name = "lblPrompt"
form1
lblPrompt
label
label
AutoSize = .T.
FontName = "MS Sans Serif"
FontSize = 8
BackStyle = 1
Caption = "Unit of Measure"
Height = 15
Left = 22
Top = 72
Width = 77
TabIndex = 0
Name = "Label6"
form1
Label6
label
label
CButtonCount = 2
Value = 1
Height = 41
Left = 14
Top = 78
Width = 155
TabIndex = 3
Name = "ogpMetric"
Option1.FontName = "MS Sans Serif"
Option1.FontSize = 8
Option1.Caption = "Englis\<h"
Option1.Value = 1
Option1.Height = 18
Option1.Left = 9
Option1.Top = 13
Option1.Width = 66
Option1.AutoSize = .F.
Option1.Name = "Option1"
Option2.FontName = "MS Sans Serif"
Option2.FontSize = 8
Option2.Caption = "\<Metric"
Option2.Value = 0
Option2.Height = 17
Option2.Left = 82
Option2.Top = 13
Option2.Width = 60
Option2.AutoSize = .F.
Option2.Name = "Option2"
form1
ogpMetric
optiongroup
optiongroup
)PROCEDURE Init
this.value = 1
ENDPROC
FontName = "MS Sans Serif"
FontSize = 8
Height = 21
InputMask = "##"
KeyboardHighValue = 20
KeyboardLowValue = 1
Left = 368
SpecialEffect = 1
SpinnerHighValue = 20.00
SpinnerLowValue = 1.00
TabIndex = 9
Top = 170
Width = 44
Value = 0
Name = "NumberAcross"
form1
NumberAcross
spinner
spinner
form1
Label3
label
label
form1
textbox
label
label
Label1
form1
AutoSize = .T.
FontName = "MS Sans Serif"
FontSize = 8
BackStyle = 0
Caption = "\<Label Name:"
Height = 15
Left = 14
Top = 14
Width = 62
TabIndex = 0
BackColor = 192,192,192
Name = "Label1"
textbox
textbox
LayoutName
form1
FontName = "MS Sans Serif"
FontSize = 8
Value = Label1
Height = 21
InputMask = "XXXXXXXXXXX"
Left = 94
TabIndex = 1
Top = 10
Width = 256
Name = "LayoutName"
textbox
textbox
Description
form1
FontName = "MS Sans Serif"
FontSize = 8
Value = 0.00" x 0.00"
Enabled = .F.
Height = 21
InputMask = "XXXXXXXXXXXXXXXXXXXXXX"
Left = 94
TabIndex = 2
Top = 40
Width = 256
DisabledForeColor = 64,0,64
Name = "Description"
image
image
Image1
form1
XPicture = label2.bmp
Height = 205
Left = 12
Top = 150
Width = 481
Name = "Image1"
shape
shape
Shape1
form1
PTop = 173
Left = 371
Height = 20
Width = 43
FillStyle = 0
Name = "Shape1"
textbox
textbox
LeftMargin
form1
FontName = "MS Sans Serif"
FontSize = 8
Alignment = 1
BackStyle = 0
BorderStyle = 0
Value = 0.00
Height = 17
InputMask = "999.9999"
Left = 30
SpecialEffect = 1
TabIndex = 4
Top = 269
Width = 55
Name = "LeftMargin"
textbox
textbox
TopMargin
form1
FontName = "MS Sans Serif"
FontSize = 8
Alignment = 3
BackStyle = 0
BorderStyle = 0
Value = 0.0000
Height = 17
InputMask = "999.9999"
Left = 129
SpecialEffect = 1
TabIndex = 5
Top = 170
Width = 60
Name = "TopMargin"
textbox
textbox
LabelHeight
form1
FontName = "MS Sans Serif"
FontSize = 8
Alignment = 1
BackStyle = 0
BorderStyle = 0
Value = 0.00
Height = 17
InputMask = "999.9999"
Left = 100
SpecialEffect = 1
TabIndex = 6
Top = 209
Width = 55
Name = "LabelHeight"
!PROCEDURE LostFocus
IF THISFORM.lChangeDesc
RETURN
ENDIF
LOCAL cDelim
m.cDelim = IIF(THISFORM.ogpMetric.Value=1,'"',' cm')
ThisForm.Description.Value = ALLTRIM(STR(ThisForm.LabelHeight.Value,8,2))+;
m.cDelim+" x "+ALLTRIM(STR(ThisForm.LabelWidth.Value,8,2))+m.cDelim
ENDPROC
FontName = "MS Sans Serif"
FontSize = 8
Alignment = 1
BackStyle = 0
Caption = "Number Across:"
Height = 15
Left = 255
Top = 173
Width = 100
TabIndex = 0
Name = "Label3"
FontName = "MS Sans Serif"
FontSize = 8
Alignment = 1
BackStyle = 0
BorderStyle = 0
Value = 0.00
Height = 17
InputMask = "999.9999"
Left = 223
SpecialEffect = 1
TabIndex = 8
Top = 313
Width = 55
Name = "SpacesBetween"
textbox
textbox
LabelWidth
form1
FontName = "MS Sans Serif"
FontSize = 8
Alignment = 1
BackStyle = 0
BorderStyle = 0
Value = 0.00
Height = 17
InputMask = "999.9999"
Left = 162
SpecialEffect = 1
TabIndex = 7
Top = 246
Width = 55
Name = "LabelWidth"
!PROCEDURE LostFocus
IF THISFORM.lChangeDesc
RETURN
ENDIF
LOCAL cDelim
m.cDelim = IIF(THISFORM.ogpMetric.Value=1,'"',' cm')
ThisForm.Description.Value = ALLTRIM(STR(ThisForm.LabelHeight.Value,8,2))+;
m.cDelim+" x "+ALLTRIM(STR(ThisForm.LabelWidth.Value,8,2))+m.cDelim
ENDPROC
SpacesBetween
textbox
PROCEDURE Click
#DEFINE ENGMEASURE '"'
#DEFINE METMEASURE ' cm'
#DEFINE ENGPROMPT_LOC "Enter label measurements in inches:"
#DEFINE METPROMPT_LOC "Enter label measurements in centimeters:"
LOCAL cDelim
IF (THIS.Value = 1 AND THISFORM.lEnglish) OR;
(THIS.Value # 1 AND !THISFORM.lEnglish)
RETURN
ENDIF
cDelim = IIF(This.Value=1,ENGMEASURE,METMEASURE)
THISFORM.lEnglish = (This.Value = 1)
IF This.Value = 1
ThisForm.lblPrompt.Caption = ENGPROMPT_LOC
* Convert metric to english
ThisForm.LeftMargin.Value = ThisForm.ConvertMM(ThisForm.LeftMargin.Value)
ThisForm.SpacesBetween.Value = ThisForm.ConvertMM(ThisForm.SpacesBetween.Value)
ThisForm.LabelWidth.Value = ThisForm.ConvertMM(ThisForm.LabelWidth.Value)
ThisForm.TopMargin.Value = ThisForm.ConvertMM(ThisForm.TopMargin.Value)
ThisForm.LabelHeight.Value = ThisForm.ConvertMM(ThisForm.LabelHeight.Value)
ThisForm.Description.Value = ALLTRIM(STR(ThisForm.LabelHeight.Value,8,2))+;
ALLTRIM(STR(ThisForm.LabelHeight.Value,8,2))
ThisForm.lblPrompt.Caption = METPROMPT_LOC
* Convert english to metric
ThisForm.LeftMargin.Value = ThisForm.ConvertMM(ThisForm.LeftMargin.Value,.t.)
ThisForm.SpacesBetween.Value = ThisForm.ConvertMM(ThisForm.SpacesBetween.Value,.t.)
ThisForm.LabelWidth.Value = ThisForm.ConvertMM(ThisForm.LabelWidth.Value,.t.)
ThisForm.TopMargin.Value = ThisForm.ConvertMM(ThisForm.TopMargin.Value,.t.)
ThisForm.LabelHeight.Value = ThisForm.ConvertMM(ThisForm.LabelHeight.Value,.t.)
ENDIF
IF !THISFORM.lChangeDesc
ThisForm.Description.Value = ALLTRIM(STR(ThisForm.LabelHeight.Value,8,2))+;
m.cDelim+" x "+ALLTRIM(STR(ThisForm.LabelWidth.Value,8,2))+m.cDelim
ENDIF
ThisForm.Refresh
ENDPROC
Please supply a value for Label Name
Please supply a value for Label Height
Please supply a value for Label Width
Please supply a value for Number Across
A label with the same name already exists, would you like to replace it?
userlbls
DATAW
LABELLYT
WzLabels
New Label Layout successfully added to labels file and registry.
NLEFTMARG
NSPACE
NLBLWID
NTOPMARG
NLBLHGT
CDATAFLD
CDESC
CDELIM
LEXISTS
CSAVENAME
THISFORM
LAYOUTNAME
VALUE
SETFOCUS
LABELHEIGHT
LABELWIDTH
NUMBERACROSS
USERLBLS
EDITMODE
WZLABELS
LEFTMARGIN
SPACESBETWEEN
TOPMARGIN
OGPMETRIC
CONVERTMM
LCHANGEDESC
NSEPPOS
CPART1
CPART2
CTMPSTR
DESCRIPTION
CKVAL
LBLDIMEN
LBLCOLUMNS
LABELTOREGISTRY
RELEASE
Click,
CINVALUE
LWHICHWAY
NINVALUE
COUTVALUE
\<Update
Enter label measurements in centimeters:
CLBLDATA
CDESC
CDELIM
CDATADESC
CMDADD
CAPTION
LAYOUTNAME
VALUE
NAME
OGPMETRIC
LBLPROMPT
LEFTMARGIN
NUMBERACROSS
SPACESBETWEEN
LABELWIDTH
TOPMARGIN
LABELHEIGHT
THISFORM
CONVERTMM
LCHANGEDESC
CPART1
CPART2
DESCRIPTION
ENABLED
CHKSET
CCHANGEVALUE
REFRESH
Software\Microsoft\VisualFoxPro\
\Labels
Could not write labels to Registry.
Updating Registry with label definitions...
Could not write labels to Registry.
NRETCODE
NSAVEAREA
CGETNAME
CGETDATA
CLBLREGKEY
VERSION
THIS
OREGISTRY
OPENKEY
CLOSEKEY
DATA
SETREGKEYh
m.lEditModeb
LEDITMODE
EDITMODE
RESETLABEL
convertmm,
resetlabel
labeltoregistry
Init&
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwp
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwp
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwp
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwp
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwww
wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
PLATFORM
UNIQUEID
TIMESTAMP
CLASS
CLASSLOC
BASECLASS
OBJNAME
PARENT
PROPERTIES
PROTECTED
METHODS
OBJCODE
RESERVED1
RESERVED2
RESERVED3
RESERVED4
RESERVED5
RESERVED6
RESERVED7
RESERVED8
COMMENT Class
WINDOWS _RJL0UQOZ1 579367670
COMMENT RESERVED
WINDOWS _RJL0UV82J 579367771
COMMENT RESERVED
WINDOWS _RJL0UXJVX 579367829
COMMENT RESERVED
WINDOWS _RJL0V1NVV 579434725
COMMENT RESERVED
WINDOWS _RJL0U66ZY 609439952z
COMMENT RESERVED
VERSION = 3.00
registry.h
registry
registry.h
Pixels
Class
custom
registry
nuserkey = 0
cvfpoptpath =
cregdllfile =
cinidllfile =
codbcdllfile =
ncurrentos = 0
ncurrentkey = 0
capppathkey =
Name = "registry"
custom
custom
Name = "odbcreg"
registry.vcx
registry.h
oldinireg
odbcreg
registry
Class
Pixels
registry.h
odbcreg
registry.h
registry.vcx
registry.h
foxreg
registry.h
Pixels
Class
registry
foxreg
Name = "foxreg"
custom
registry.h
Pixels
registry
Class
registry.h
filereg
registry.h
Pixels
Class
registry
filereg
*setfoxoption Sets an option from FoxPro registry settings.
*getfoxoption Retrieves an option from FoxPro registry settings.
*enumfoxoptions
Name = "filereg"
custom
registry.vcx
PROCEDURE setfoxoption
LPARAMETER cOptName,cOptVal
RETURN THIS.SetRegKey(cOptName,cOptVal,THIS.cVFPOptPath,THIS.nUserKey)
ENDPROC
PROCEDURE getfoxoption
LPARAMETER cOptName,cOptVal
RETURN THIS.GetRegKey(cOptName,@cOptVal,THIS.cVFPOptPath,THIS.nUserKey)
ENDPROC
PROCEDURE enumoptions
LPARAMETER aFoxOpts
RETURN THIS.EnumOptions(@aFoxOpts,THIS.cVFPOptPath,THIS.nUserKey,.F.)
ENDPROC
registry.vcx
custom
oldinireg
Name = "oldinireg"
m.cExtensionb
CEXTENSION
CEXTNKEY
CAPPKEY
LSERVER
NERRNUM
COPTNAME
OPENKEY
GETKEYVALUE
CLOSEKEY
GETAPPLICATION
\CurVer
CCLASS
CEXTNKEY
CAPPKEY
LSERVER
NERRNUM
COPTNAME
OPENKEY
GETKEYVALUE
CLOSEKEY
GETAPPLICATION
m.lServerb
\Protocol\StdFileEditing\Server
\Shell\Open\Command
CEXTNKEY
CAPPKEY
LSERVER
NERRNUM
COPTNAME
CAPPPATHKEY
OPENKEY
GETKEYVALUE
CLOSEKEY
getapppath,
getlatestversion
getapplication
SQLDrivers
SQLDataSources
LLOADEDODBCS
CODBCDLLFILE
FDIRECTION
SZDRIVERDESC
CBDRIVERDESCMAX
PCBDRIVERDESC
SZDRIVERATTRIBUTES
CBDRVRATTRMAX
PCBDRVRATTR
SZDSN
CBDSNMAX
PCBDSN
SZDESCRIPTION
CBDESCRIPTIONMAX
PCBDESCRIPTION
SQLDRIVERS
LHADERROR
SQLDATASOURCES!
m.lDataSourcesb
ADRVRS
LDATASOURCES
NODBCENV
NRETVAL
DSNDESC
MDESC
LOADODBCFUNCS
SQLDATASOURCES
SQLDRIVERSa
Software\ODBC\ODBCINST.INI\
ADRVROPTS
CODBCDRIVER
CSOURCEKEY
ENUMOPTIONS[
Software\ODBC\ODBC.INI\
ADRVROPTS
CDATASOURCE
CSOURCEKEY
ENUMOPTIONS
loadodbcfuncs,
getodbcdrvrsH
enumodbcdrvrs
enumodbcdata~
COPTNAME
COPTVAL
THIS
SETREGKEY
CVFPOPTPATH
NUSERKEY/
COPTNAME
COPTVAL
THIS
GETREGKEY
CVFPOPTPATH
NUSERKEY(
AFOXOPTS
ENUMOPTIONS
CVFPOPTPATH
NUSERKEY
setfoxoption,
getfoxoption
enumoptions
*getapppath Checks and returns path of application associated with a particular extension (e.g., XLS, DOC).
*getlatestversion Returns latest version for a specified application.
*getapplication Retrieves application key.
*getinisection Retrieves information from INI section.
*getinientry Retrieves information from INI entry.
*writeinientry Writes a specific INI entry.
*loadinifuncs Loads functions needed for reading INI files.
*loadodbcfuncs Loads ODBC registry functions.
*getodbcdrvrs Retrieves ODBC drivers.
*enumodbcdrvrs Enumerates through ODBC drivers.
*enumodbcdata Enumerates through ODBC data sources.
GPROCEDURE loadodbcfuncs
IF THIS.lLoadedODBCs
RETURN ERROR_SUCCESS
ENDIF
* Check API file containing functions
IF EMPTY(THIS.cODBCDLLFile)
RETURN ERROR_NOODBCFILE
ENDIF
LOCAL henv,fDirection,szDriverDesc,cbDriverDescMax
LOCAL pcbDriverDesc,szDriverAttributes,cbDrvrAttrMax,pcbDrvrAttr
LOCAL szDSN,cbDSNMax,pcbDSN,szDescription,cbDescriptionMax,pcbDescription
DECLARE Short SQLDrivers IN (THIS.cODBCDLLFile) ;
Integer henv, Integer fDirection, ;
String @ szDriverDesc, Integer cbDriverDescMax, Integer pcbDriverDesc, ;
String @ szDriverAttributes, Integer cbDrvrAttrMax, Integer pcbDrvrAttr
IF THIS.lhaderror && error loading library
RETURN -1
ENDIF
DECLARE Short SQLDataSources IN (THIS.cODBCDLLFile) ;
Integer henv, Integer fDirection, ;
String @ szDSN, Integer cbDSNMax, Integer @ pcbDSN, ;
String @ szDescription, Integer cbDescriptionMax,Integer pcbDescription
THIS.lLoadedODBCs = .T.
RETURN ERROR_SUCCESS
ENDPROC
PROCEDURE getodbcdrvrs
PARAMETER aDrvrs,lDataSources
LOCAL nODBCEnv,nRetVal,dsn,dsndesc,mdsn,mdesc
lDataSources = IIF(TYPE("m.lDataSources")="L",m.lDataSources,.F.)
* Load API functions
nRetVal = THIS.LoadODBCFuncs()
IF m.nRetVal # ERROR_SUCCESS
RETURN m.nRetVal
ENDIF
* Get ODBC environment handle
nODBCEnv=VAL(SYS(3053))
* -- Possible error messages
* 527 "cannot load odbc library"
* 528 "odbc entry point missing"
* 182 "not enough memory"
IF INLIST(nODBCEnv,527,528,182)
* Failed
RETURN ERROR_ODBCFAIL
ENDIF
DIMENSION aDrvrs[1,IIF(m.lDataSources,2,1)]
aDrvrs[1] = ""
DO WHILE .T.
dsn=space(100)
dsndesc=space(100)
mdsn=0
mdesc=0
* Return drivers or data sources
IF m.lDataSources
nRetVal = SQLDataSources(m.nODBCEnv,SQL_FETCH_NEXT,@dsn,100,@mdsn,@dsndesc,255,@mdesc)
ELSE
nRetVal = SQLDrivers(m.nODBCEnv,SQL_FETCH_NEXT,@dsn,100,@mdsn,@dsndesc,100,@mdesc)
ENDIF
DO CASE
CASE m.nRetVal = SQL_NO_DATA
nRetVal = ERROR_SUCCESS
EXIT
CASE m.nRetVal # ERROR_SUCCESS AND m.nRetVal # 1
EXIT
OTHERWISE
IF !EMPTY(aDrvrs[1])
IF m.lDataSources
DIMENSION aDrvrs[ALEN(aDrvrs,1)+1,2]
ELSE
DIMENSION aDrvrs[ALEN(aDrvrs,1)+1,1]
ENDIF
ENDIF
dsn = ALLTRIM(m.dsn)
aDrvrs[ALEN(aDrvrs,1),1] = LEFT(m.dsn,LEN(m.dsn)-1)
IF m.lDataSources
dsndesc = ALLTRIM(m.dsndesc)
aDrvrs[ALEN(aDrvrs,1),2] = LEFT(m.dsndesc,LEN(m.dsndesc)-1)
ENDIF
ENDCASE
ENDDO
RETURN nRetVal
ENDPROC
PROCEDURE enumodbcdrvrs
LPARAMETER aDrvrOpts,cODBCDriver
LOCAL cSourceKey
cSourceKey = ODBC_DRVRS_KEY+m.cODBCDriver
RETURN THIS.EnumOptions(@aDrvrOpts,m.cSourceKey,HKEY_LOCAL_MACHINE,.F.)
ENDPROC
PROCEDURE enumodbcdata
LPARAMETER aDrvrOpts,cDataSource
LOCAL cSourceKey
cSourceKey = ODBC_DATA_KEY+cDataSource
RETURN THIS.EnumOptions(@aDrvrOpts,m.cSourceKey,HKEY_CURRENT_USER,.F.)
ENDPROC
m.cINIFileb
ASECTIONS
CSECTION
CINIFILE
CINIVALUE
NTOTENTRIES
NLASTPOS
GETINIENTRY
NTMPPOSY
CVALUE
CSECTION
CENTRY
CINIFILE
CBUFFER
NBUFSIZE
NERRNUM
NTOTPARMS
LOADINIFUNCS
GETWININI
GETPRIVATEINI
CVALUE
CSECTION
CENTRY
CINIFILE
NERRNUM
LOADINIFUNCS
WRITEWININI
WRITEPRIVATEINIW
GetPrivateProfileString
Win32APIQ
GetPrivateINI
GetProfileString
Win32APIQ
GetWinINI
WriteProfileString
Win32APIQ
WriteWinINI
WritePrivateProfileString
Win32APIQ
WritePrivateINI
LLOADEDINIS
GETPRIVATEPROFILESTRING
WIN32API
GETPRIVATEINI
LHADERROR
GETPROFILESTRING
GETWININI
WRITEPROFILESTRING
WRITEWININI
WRITEPRIVATEPROFILESTRING
WRITEPRIVATEINI
getinisection,
getinientry
writeinientry
loadinifuncs
PROCEDURE getapppath
* Checks and returns path of application
* associated with a particular extension (e.g., XLS, DOC).
LPARAMETER cExtension,cExtnKey,cAppKey,lServer
LOCAL nErrNum,cOptName
cOptName = ""
* Check Extension parameter
IF TYPE("m.cExtension") # "C" OR LEN(m.cExtension) > 3
RETURN ERROR_BADPARM
ENDIF
m.cExtension = "."+m.cExtension
* Open extension key
nErrNum = THIS.OpenKey(m.cExtension)
IF m.nErrNum # ERROR_SUCCESS
RETURN m.nErrNum
ENDIF
* Get key value for file extension
nErrNum = THIS.GetKeyValue(cOptName,@cExtnKey)
* Close extension key
THIS.CloseKey()
IF m.nErrNum # ERROR_SUCCESS
RETURN m.nErrNum
ENDIF
RETURN THIS.GetApplication(cExtnKey,@cAppKey,lServer)
ENDPROC
PROCEDURE getlatestversion
LPARAMETER cClass,cExtnKey,cAppKey,lServer
LOCAL nErrNum,cOptName
cOptName = ""
* Open class key (e.g., Excel.Sheet)
nErrNum = THIS.OpenKey(m.cClass+CURVER_KEY)
IF m.nErrNum # ERROR_SUCCESS
RETURN m.nErrNum
ENDIF
* Get key value for file extension
nErrNum = THIS.GetKeyValue(cOptName,@cExtnKey)
* Close extension key
THIS.CloseKey()
IF m.nErrNum # ERROR_SUCCESS
RETURN m.nErrNum
ENDIF
RETURN THIS.GetApplication(cExtnKey,@cAppKey,lServer)
ENDPROC
PROCEDURE getapplication
PARAMETER cExtnKey,cAppKey,lServer
LOCAL nErrNum,cOptName
cOptName = ""
* lServer - checking for OLE server.
IF TYPE("m.lServer") = "L" AND m.lServer
THIS.cAppPathKey = OLE_PATH_KEY
ELSE
THIS.cAppPathKey = APP_PATH_KEY
ENDIF
* Open extension app key
m.nErrNum = THIS.OpenKey(m.cExtnKey+THIS.cAppPathKey)
IF m.nErrNum # ERROR_SUCCESS
RETURN m.nErrNum
ENDIF
* Get application path
nErrNum = THIS.GetKeyValue(cOptName,@cAppKey)
* Close application path key
THIS.CloseKey()
RETURN m.nErrNum
ENDPROC
PROCEDURE getinisection
PARAMETERS aSections,cSection,cINIFile
LOCAL cINIValue, nTotEntries, i, nLastPos
cINIValue = ""
IF TYPE("m.cINIFile") # "C"
cINIFile = ""
ENDIF
IF THIS.GetINIEntry(@cINIValue,cSection,0,m.cINIFile) # ERROR_SUCCESS
RETURN ERROR_FAILINI
ENDIF
nTotEntries=OCCURS(CHR(0),m.cINIValue)
DIMENSION aSections[m.nTotEntries]
nLastPos = 1
FOR i = 1 TO m.nTotEntries
nTmpPos = AT(CHR(0),m.cINIValue,m.i)
aSections[m.i] = SUBSTR(m.cINIValue,m.nLastPos,m.nTmpPos-m.nLastPos)
nLastPos = m.nTmpPos+1
ENDFOR
RETURN ERROR_SUCCESS
ENDPROC
PROCEDURE getinientry
LPARAMETER cValue,cSection,cEntry,cINIFile
* Get entry from INI file
LOCAL cBuffer,nBufSize,nErrNum,nTotParms
nTotParms = PARAMETERS()
* Load API functions
nErrNum= THIS.LoadINIFuncs()
IF m.nErrNum # ERROR_SUCCESS
RETURN m.nErrNum
ENDIF
* Parameter checks here
IF m.nTotParms < 3
m.cEntry = 0
ENDIF
m.cBuffer=space(2000)
IF EMPTY(m.cINIFile)
* WIN.INI file
m.nBufSize = GetWinINI(m.cSection,m.cEntry,"",@cBuffer,LEN(m.cBuffer))
* Private INI file
m.nBufSize = GetPrivateINI(m.cSection,m.cEntry,"",@cBuffer,LEN(m.cBuffer),m.cINIFile)
ENDIF
IF m.nBufSize = 0 &&could not find entry in INI file
RETURN ERROR_NOINIENTRY
ENDIF
m.cValue=LEFT(m.cBuffer,m.nBufSize)
** All is well
RETURN ERROR_SUCCESS
ENDPROC
PROCEDURE writeinientry
LPARAMETER cValue,cSection,cEntry,cINIFile
* Get entry from INI file
LOCAL nErrNum
* Load API functions
nErrNum = THIS.LoadINIFuncs()
IF m.nErrNum # ERROR_SUCCESS
RETURN m.nErrNum
ENDIF
IF EMPTY(m.cINIFile)
* WIN.INI file
nErrNum = WriteWinINI(m.cSection,m.cEntry,m.cValue)
* Private INI file
nErrNum = WritePrivateINI(m.cSection,m.cEntry,m.cValue,m.cINIFile)
ENDIF
** All is well
RETURN IIF(m.nErrNum=1,ERROR_SUCCESS,m.nErrNum)
ENDPROC
PROCEDURE loadinifuncs
* Loads funtions needed for reading INI files
IF THIS.lLoadedINIs
RETURN ERROR_SUCCESS
ENDIF
DECLARE integer GetPrivateProfileString IN Win32API ;
AS GetPrivateINI string,string,string,string,integer,string
IF THIS.lhaderror && error loading library
RETURN -1
ENDIF
DECLARE integer GetProfileString IN Win32API ;
AS GetWinINI string,string,string,string,integer
DECLARE integer WriteProfileString IN Win32API ;
AS WriteWinINI string,string,string
DECLARE integer WritePrivateProfileString IN Win32API ;
AS WritePrivateINI string,string,string,string
THIS.lLoadedINIs = .T.
* Need error check here
RETURN ERROR_SUCCESS
ENDPROC
nuserkey User registry key.
cvfpoptpath Registry path to VFP options settings.
cregdllfile DLL file for registry functions.
cinidllfile DLL file for INI functions.
codbcdllfile DLL file for ODBC functions.
ncurrentos Current operating system code.
ncurrentkey Current registry key.
lloadeddlls Whether registry key functions loaded.
lloadedinis Whether INI functions loaded.
capppathkey Application path registry key.
lcreatekey Whether to create key if one does not already exist.
lhaderror Whether an error occurred.
lloadedodbcs Whether ODBC functions loaded.
*loadregfuncs Loads funtions needed for Registry.
*openkey Opens a registry key.
*closekey Closes a registry key.
*setregkey Sets a registry key setting.
*getregkey Gets a registry key setting.
*getkeyvalue Obtains a value from a registry key.
*setkeyvalue Sets a key value.
*deletekey Deletes a registry key.
*enumoptions Enumerates through all entries for a key and populates array.
*iskey Checks to see if a key exists.
*enumkeys Enumerates through a registry key.
*enumkeyvalues Enumerates through values of a registry key
*deletekeyvalue Deletes value from registry key.
RegOpenKey
Win32API
RegCreateKey
Win32API
RegDeleteKey
Win32API
RegDeleteValue
Win32API
RegCloseKey
Win32API
RegSetValueEx
Win32API
RegQueryValueEx
Win32API
RegEnumKey
Win32API
RegEnumKeyEx
Win32API
RegEnumValue
Win32API
NHKEY
CSUBKEY
NRESULT
IVALUE
LPSZVALUE
LPCCHVALUE
LPDWTYPE
LPBDATA
LPCBDATA
LPCSTR
LPSZVAL
LPDWRESERVED
LPSZVALUENAME
DWRESERVED
FDWTYPE
ISUBKEY
LPSZNAME
CCHNAME
LLOADEDDLLS
REGOPENKEY
WIN32API
LHADERROR
REGCREATEKEY
REGDELETEKEY
REGDELETEVALUE
REGCLOSEKEY
REGSETVALUEEX
REGQUERYVALUEEX
REGENUMKEY
REGENUMKEYEX
REGENUMVALUE
m.nRegKeyb
m.lCreateKeyb
CLOOKUPKEY
NREGKEY
LCREATEKEY
NSUBKEY
NERRCODE
NPCOUNT
LSAVECREATEKEY
LOADREGFUNCS
REGCREATEKEY
REGOPENKEY
NCURRENTKEY#
REGCLOSEKEY
NCURRENTKEY
COPTNAME
COPTVAL
CKEYPATH
NUSERKEY
LCREATEKEY
COPTKEY
COPTION
NERRNUM
OPENKEY
SETKEYVALUE
CLOSEKEY
COPTNAME
COPTVAL
CKEYPATH
NUSERKEY
COPTKEY
COPTION
NERRNUM
OPENKEY
GETKEYVALUE
CLOSEKEYs
THIS.nCurrentKeyb
m.cValueNameb
CVALUENAME
CKEYVALUE
LPDWRESERVED
LPDWTYPE
LPBDATA
LPCBDATA
NERRCODE
NCURRENTKEY
REGQUERYVALUEEXA
THIS.nCurrentKeyb
m.cValueNameb
m.cValueb
CVALUENAME
CVALUE
NVALUESIZE
NERRCODE
NCURRENTKEY
REGSETVALUEEXI
NUSERKEY
CKEYPATH
NERRNUM
REGDELETEKEY&
m.lEnumKeysb
AREGOPTS
COPTPATH
NUSERKEY
LENUMKEYS
COPTKEY
COPTION
NERRNUM
OPENKEY
ENUMKEYS
ENUMKEYVALUES
CLOSEKEYe
CKEYNAME
NREGKEY
NERRNUM
OPENKEY
CLOSEKEY
AKEYNAMES
NKEYENTRY
CNEWKEY
CNEWSIZE
NBUFLEN
CRETTIME
NKEYSIZE
NERRCODE
REGENUMKEYEX
NCURRENTKEY
THIS.nCurrentKeyb
*Binary*
*Unknown type*
AKEYVALUES
LPSZVALUE
LPCCHVALUE
LPDWRESERVED
LPDWTYPE
LPBDATA
LPCBDATA
NERRCODE
NKEYENTRY
LARRAYPASSED
NCURRENTKEY
NCURRENTOS
REGENUMVALUE
COPTNAME
CKEYPATH
NUSERKEY
COPTION
NERRNUM
OPENKEY
REGDELETEVALUE
NCURRENTKEY
CLOSEKEY+
NERROR
CMETHOD
NLINE
THIS
LHADERROR
Software\Microsoft\VisualFoxPro\
\Options
Windows 3C
Windows NTC
ADVAPI32.DLL
KERNEL32.DLL
ODBC32.DLL
ADVAPI32.DLL
KERNEL32.DLL
ODBC32.DLL
NUSERKEY
CVFPOPTPATH
VERSION
NCURRENTOS
CREGDLLFILE
CINIDLLFILE
CODBCDLLFILE
loadregfuncs,
openkey
closekey2
setregkeyy
getregkey
getkeyvalue
setkeyvalue
deletekeys
enumoptions
iskey
enumkeys/
enumkeyvalues
deletekeyvalue
Error+
PROCEDURE loadregfuncs
* Loads funtions needed for Registry
LOCAL nHKey,cSubKey,nResult
LOCAL hKey,iValue,lpszValue,lpcchValue,lpdwType,lpbData,lpcbData
LOCAL lpcStr,lpszVal,nLen,lpdwReserved
LOCAL lpszValueName,dwReserved,fdwType
LOCAL iSubKey,lpszName,cchName
IF THIS.lLoadedDLLs
RETURN ERROR_SUCCESS
ENDIF
DECLARE Integer RegOpenKey IN Win32API ;
Integer nHKey, String @cSubKey, Integer @nResult
IF THIS.lhaderror && error loading library
RETURN -1
ENDIF
DECLARE Integer RegCreateKey IN Win32API ;
Integer nHKey, String @cSubKey, Integer @nResult
DECLARE Integer RegDeleteKey IN Win32API ;
Integer nHKey, String @cSubKey
DECLARE Integer RegDeleteValue IN Win32API ;
Integer nHKey, String cSubKey
DECLARE Integer RegCloseKey IN Win32API ;
Integer nHKey
DECLARE Integer RegSetValueEx IN Win32API ;
Integer hKey, String lpszValueName, Integer dwReserved,;
Integer fdwType, String lpbData, Integer cbData
DECLARE Integer RegQueryValueEx IN Win32API ;
Integer nHKey, String lpszValueName, Integer dwReserved,;
Integer @lpdwType, String @lpbData, Integer @lpcbData
DECLARE Integer RegEnumKey IN Win32API ;
Integer nHKey,Integer iSubKey, String @lpszName, Integer @cchName
DECLARE Integer RegEnumKeyEx IN Win32API ;
Integer nHKey,Integer iSubKey, String @lpszName, Integer @cchName,;
Integer dwReserved,String @lpszName, Integer @cchName,String @cchName
DECLARE Integer RegEnumValue IN Win32API ;
Integer hKey, Integer iValue, String @lpszValue, ;
Integer @lpcchValue, Integer lpdwReserved, Integer @lpdwType, ;
String @lpbData, Integer @lpcbData
THIS.lLoadedDLLs = .T.
* Need error check here
RETURN ERROR_SUCCESS
ENDPROC
PROCEDURE openkey
* Opens a registry key
LPARAMETER cLookUpKey,nRegKey,lCreateKey
LOCAL nSubKey,nErrCode,nPCount,lSaveCreateKey
nSubKey = 0
nPCount = PARAMETERS()
IF TYPE("m.nRegKey") # "N" OR EMPTY(m.nRegKey)
m.nRegKey = HKEY_CLASSES_ROOT
ENDIF
* Load API functions
nErrCode = THIS.LoadRegFuncs()
IF m.nErrCode # ERROR_SUCCESS
RETURN m.nErrCode
ENDIF
lSaveCreateKey = THIS.lCreateKey
IF m.nPCount>2 AND TYPE("m.lCreateKey") = "L"
THIS.lCreateKey = m.lCreateKey
ENDIF
IF THIS.lCreateKey
* Try to open or create registry key
nErrCode = RegCreateKey(m.nRegKey,m.cLookUpKey,@nSubKey)
* Try to open registry key
nErrCode = RegOpenKey(m.nRegKey,m.cLookUpKey,@nSubKey)
ENDIF
THIS.lCreateKey = m.lSaveCreateKey
IF nErrCode # ERROR_SUCCESS
RETURN m.nErrCode
ENDIF
THIS.nCurrentKey = m.nSubKey
RETURN ERROR_SUCCESS
ENDPROC
PROCEDURE closekey
* Closes a registry key
=RegCloseKey(THIS.nCurrentKey)
THIS.nCurrentKey =0
ENDPROC
PROCEDURE setregkey
* This routine sets a registry key setting
* ex. THIS.SetRegKey("ResWidth","640",;
* "Software\Microsoft\VisualFoxPro\6.0\Options",;
* HKEY_CURRENT_USER)
LPARAMETER cOptName,cOptVal,cKeyPath,nUserKey,lCreateKey
LOCAL iPos,cOptKey,cOption,nErrNum
iPos = 0
cOption = ""
nErrNum = ERROR_SUCCESS
* Open registry key
m.nErrNum = THIS.OpenKey(m.cKeyPath,m.nUserKey,m.lCreateKey)
IF m.nErrNum # ERROR_SUCCESS
RETURN m.nErrNum
ENDIF
* Set Key value
nErrNum = THIS.SetKeyValue(m.cOptName,m.cOptVal)
* Close registry key
THIS.CloseKey() &&close key
RETURN m.nErrNum
ENDPROC
PROCEDURE getregkey
* This routine gets a registry key setting
* ex. THIS.GetRegKey("ResWidth",@cValue,;
* "Software\Microsoft\VisualFoxPro\4.0\Options",;
* HKEY_CURRENT_USER)
LPARAMETER cOptName,cOptVal,cKeyPath,nUserKey
LOCAL iPos,cOptKey,cOption,nErrNum
iPos = 0
cOption = ""
nErrNum = ERROR_SUCCESS
* Open registry key
m.nErrNum = THIS.OpenKey(m.cKeyPath,m.nUserKey)
IF m.nErrNum # ERROR_SUCCESS
RETURN m.nErrNum
ENDIF
* Get the key value
nErrNum = THIS.GetKeyValue(cOptName,@cOptVal)
* Close registry key
THIS.CloseKey() &&close key
RETURN m.nErrNum
ENDPROC
PROCEDURE getkeyvalue
* Obtains a value from a registry key
* Note: this routine only handles Data strings (REG_SZ)
LPARAMETER cValueName,cKeyValue
LOCAL lpdwReserved,lpdwType,lpbData,lpcbData,nErrCode
STORE 0 TO lpdwReserved,lpdwType
STORE SPACE(256) TO lpbData
STORE LEN(m.lpbData) TO m.lpcbData
DO CASE
CASE TYPE("THIS.nCurrentKey")#'N' OR THIS.nCurrentKey = 0
RETURN ERROR_BADKEY
CASE TYPE("m.cValueName") #"C"
RETURN ERROR_BADPARM
ENDCASE
m.nErrCode=RegQueryValueEx(THIS.nCurrentKey,m.cValueName,;
m.lpdwReserved,@lpdwType,@lpbData,@lpcbData)
* Check for error
IF m.nErrCode # ERROR_SUCCESS
RETURN m.nErrCode
ENDIF
* Make sure we have a data string data type
IF m.lpdwType # REG_SZ AND m.lpdwType # REG_EXPAND_SZ
RETURN ERROR_NONSTR_DATA
ENDIF
m.cKeyValue = LEFT(m.lpbData,m.lpcbData-1)
RETURN ERROR_SUCCESS
ENDPROC
PROCEDURE setkeyvalue
* This routine sets a key value
* Note: this routine only handles data strings (REG_SZ)
LPARAMETER cValueName,cValue
LOCAL nValueSize,nErrCode
DO CASE
CASE TYPE("THIS.nCurrentKey")#'N' OR THIS.nCurrentKey = 0
RETURN ERROR_BADKEY
CASE TYPE("m.cValueName") #"C" OR TYPE("m.cValue")#"C"
RETURN ERROR_BADPARM
CASE EMPTY(m.cValueName) OR EMPTY(m.cValue)
* RETURN ERROR_BADPARM
ENDCASE
* Make sure we null terminate this guy
cValue = m.cValue+CHR(0)
nValueSize = LEN(m.cValue)
* Set the key value here
m.nErrCode = RegSetValueEx(THIS.nCurrentKey,m.cValueName,0,;
REG_SZ,m.cValue,m.nValueSize)
* Check for error
IF m.nErrCode # ERROR_SUCCESS
RETURN m.nErrCode
ENDIF
RETURN ERROR_SUCCESS
ENDPROC
PROCEDURE deletekey
* This routine deletes a Registry Key
LPARAMETER nUserKey,cKeyPath
LOCAL nErrNum
nErrNum = ERROR_SUCCESS
* Delete key
m.nErrNum = RegDeleteKey(m.nUserKey,m.cKeyPath)
RETURN m.nErrNum
ENDPROC
PROCEDURE enumoptions
* Enumerates through all entries for a key and populates array
LPARAMETER aRegOpts,cOptPath,nUserKey,lEnumKeys
LOCAL iPos,cOptKey,cOption,nErrNum
iPos = 0
cOption = ""
nErrNum = ERROR_SUCCESS
IF PARAMETERS()<4 OR TYPE("m.lEnumKeys") # "L"
lEnumKeys = .F.
ENDIF
* Open key
m.nErrNum = THIS.OpenKey(m.cOptPath,m.nUserKey)
IF m.nErrNum # ERROR_SUCCESS
RETURN m.nErrNum
ENDIF
* Enumerate through keys
IF m.lEnumKeys
* Enumerate and get key names
nErrNum = THIS.EnumKeys(@aRegOpts)
* Enumerate and get all key values
nErrNum = THIS.EnumKeyValues(@aRegOpts)
ENDIF
* Close key
THIS.CloseKey() &&close key
RETURN m.nErrNum
ENDPROC
PROCEDURE iskey
* Checks to see if a key exists
LPARAMETER cKeyName,nRegKey
LOCAL nErrNum
* Open extension key
nErrNum = THIS.OpenKey(m.cKeyName,m.nRegKey)
IF m.nErrNum = ERROR_SUCCESS
* Close extension key
THIS.CloseKey()
ENDIF
RETURN m.nErrNum = ERROR_SUCCESS
ENDPROC
PROCEDURE enumkeys
PARAMETER aKeyNames
LOCAL nKeyEntry,cNewKey,cNewSize,cbuf,nbuflen,cRetTime
nKeyEntry = 0
DIMENSION aKeyNames[1]
DO WHILE .T.
nKeySize = 0
cNewKey = SPACE(100)
nKeySize = LEN(m.cNewKey)
cbuf=space(100)
nbuflen=len(m.cbuf)
cRetTime=space(100)
m.nErrCode = RegEnumKeyEx(THIS.nCurrentKey,m.nKeyEntry,@cNewKey,@nKeySize,0,@cbuf,@nbuflen,@cRetTime)
DO CASE
CASE m.nErrCode = ERROR_EOF
EXIT
CASE m.nErrCode # ERROR_SUCCESS
EXIT
ENDCASE
cNewKey = ALLTRIM(m.cNewKey)
cNewKey = LEFT(m.cNewKey,LEN(m.cNewKey)-1)
IF !EMPTY(aKeyNames[1])
DIMENSION aKeyNames[ALEN(aKeyNames)+1]
ENDIF
aKeyNames[ALEN(aKeyNames)] = m.cNewKey
nKeyEntry = m.nKeyEntry + 1
ENDDO
IF m.nErrCode = ERROR_EOF AND m.nKeyEntry # 0
m.nErrCode = ERROR_SUCCESS
ENDIF
RETURN m.nErrCode
ENDPROC
PROCEDURE enumkeyvalues
* Enumerates through values of a registry key
LPARAMETER aKeyValues
LOCAL lpszValue,lpcchValue,lpdwReserved
LOCAL lpdwType,lpbData,lpcbData
LOCAL nErrCode,nKeyEntry,lArrayPassed
STORE 0 TO nKeyEntry
IF TYPE("THIS.nCurrentKey")#'N' OR THIS.nCurrentKey = 0
RETURN ERROR_BADKEY
ENDIF
* Sorry, Win32s does not support this one!
IF THIS.nCurrentOS = OS_W32S
RETURN ERROR_BADPLAT
ENDIF
DO WHILE .T.
STORE 0 TO lpdwReserved,lpdwType,nErrCode
STORE SPACE(256) TO lpbData, lpszValue
STORE LEN(lpbData) TO m.lpcchValue
STORE LEN(lpszValue) TO m.lpcbData
nErrCode=RegEnumValue(THIS.nCurrentKey,m.nKeyEntry,@lpszValue,;
@lpcchValue,m.lpdwReserved,@lpdwType,@lpbData,@lpcbData)
DO CASE
CASE m.nErrCode = ERROR_EOF
EXIT
CASE m.nErrCode # ERROR_SUCCESS
EXIT
ENDCASE
nKeyEntry = m.nKeyEntry + 1
* Set array values
DIMENSION aKeyValues[m.nKeyEntry,2]
aKeyValues[m.nKeyEntry,1] = LEFT(m.lpszValue,m.lpcchValue)
DO CASE
CASE lpdwType = REG_SZ
aKeyValues[m.nKeyEntry,2] = LEFT(m.lpbData,m.lpcbData-1)
CASE lpdwType = REG_BINARY
* Don't support binary
aKeyValues[m.nKeyEntry,2] = REG_BINARY_LOC
CASE lpdwType = REG_DWORD
* You will need to use ASC() to check values here.
aKeyValues[m.nKeyEntry,2] = LEFT(m.lpbData,m.lpcbData-1)
OTHERWISE
aKeyValues[m.nKeyEntry,2] = REG_UNKNOWN_LOC
ENDCASE
ENDDO
IF m.nErrCode = ERROR_EOF AND m.nKeyEntry # 0
m.nErrCode = ERROR_SUCCESS
ENDIF
RETURN m.nErrCode
ENDPROC
PROCEDURE deletekeyvalue
LPARAMETER cOptName,cKeyPath,nUserKey
LOCAL cOption,nErrNum
cOption = cOptName
nErrNum = ERROR_SUCCESS
* Open key
m.nErrNum = THIS.OpenKey(m.cKeyPath,m.nUserKey)
IF m.nErrNum # ERROR_SUCCESS
RETURN m.nErrNum
ENDIF
* Delete the key value
m.nErrNum = RegDeleteValue(THIS.nCurrentKey,m.cOption)
* Close key
THIS.CloseKey() && close key
RETURN m.nErrNum
ENDPROC
PROCEDURE Error
LPARAMETERS nError, cMethod, nLine
THIS.lhaderror = .T.
=MESSAGEBOX(MESSAGE())
ENDPROC
PROCEDURE Init
THIS.nUserKey = HKEY_CURRENT_USER
THIS.cVFPOptPath = VFP_OPTIONS_KEY1 + _VFP.VERSION + VFP_OPTIONS_KEY2
DO CASE
CASE _DOS OR _UNIX OR _MAC
RETURN .F.
CASE ATC("Windows 3",OS(1)) # 0
THIS.nCurrentOS = OS_W32S
CASE ATC("Windows NT",OS(1)) # 0
THIS.nCurrentOS = OS_NT
THIS.cRegDLLFile = DLL_ADVAPI_NT
THIS.cINIDLLFile = DLL_KERNEL_NT
THIS.cODBCDLLFile = DLL_ODBC_NT
OTHERWISE
* Windows 95
THIS.nCurrentOS = OS_WIN95
THIS.cRegDLLFile = DLL_ADVAPI_WIN95
THIS.cINIDLLFile = DLL_KERNEL_WIN95
THIS.cODBCDLLFile = DLL_ODBC_WIN95
ENDCASE
ENDPROC
addlabel.scx
addlabel.sct
d:\8146\fox60\dev\
6d4x027x.fxp
newlabel.scx
newlabel.sct
label2.bmp
label2.msk
..\wzcommon\
registry.vcx
registry.vct