تکه کد های جالب

[hamed_m]

اگر دوستان موافق باشند در این تاپیک تکه کدهای جالب و بدرد بخور رو قرار بدیم.

پیدا کردن شماره سریال سی پی یو (البته در ایکس پی جواب میده اما هم با اینتل هم با ای ام دی خوب کار میکنه) :

name1=chrtran(SYS(0)," ","")

name1=chrtran(name1,"#","!")

LOCAL lcComputerName, loWMI, lowmiWin32Objects, lowmiWin32Object

lcComputerName = GETWORDNUM(SYS(0),1)

loWMI = GETOBJECT("WinMgmts://" + lcComputerName)

lowmiWin32Objects = loWMI.InstancesOf("Win32_Processor")

FOR EACH lowmiWin32Object IN lowmiWin32Objects

    WITH lowmiWin32Object

        ProcessorId= TRANSFORM(.ProcessorId) 

    ENDWITH

ENDFOR



ProcessorId1=""



FOR i=1 TO LEN(ProcessorId)

IF (VAL(SUBSTR(ProcessorId,i,1)))<9 AND (VAL(SUBSTR(ProcessorId,i,1)))>0

ProcessorId1=ProcessorId1+CHR(ASC(SUBSTR(Processor  Id,i,1))+0)

ELSE

ProcessorId1=ProcessorId1+CHR(ASC(SUBSTR(Processor  Id,i,1))+0)

ENDIF

ENDFOR

مک آدرس دستگاه (اینهم با ایکس پی خوب کار میکنه):

LOCAL gcMacAddress

gcMacAddress = .null.

loloc = CREATEOBJECT("WbemScripting.SWbemLocator")

lowmi = loloc.connectServer()

lomac = lowmi.InstancesOf("Win32_NetworkAdapterConfigurati  on")

FOR EACH loMacAddr IN lomac

    IF loMacAddr.IPEnabled 

        gcMacAddress = loMacAddr.MACAddress

        EXIT

    ENDIF

NEXT    

STORE .null. to loloc,lowmi,lomac,loMacAddr

? "MAC ADDRESS:" + gcMacAddress

[hamed_m]

تنها یکبار اجازه اجرای برنامه تون رو بدید:

******************test run******************************************

#Define AtomStrLength   512

public lcAtomName,natom2

lcAtomName = "MYPRG"

Declare Integer GlobalAddAtom In win32api String

Declare Integer GlobalDeleteAtom In win32api Integer

Declare Integer GlobalGetAtomName In kernel32;

     INTEGER  nAtom,;

     STRING @ lpBuffer,;

     INTEGER  nSize

findAtom(lcAtomName)



Function findAtom(tcAtom)

Create Cursor cs (atom N(12), strlen N(5), Name C(100))

Index On Allt(Name) Tag Name

For nAtom = 49152 To 65535

     lpBuffer = Repli(Chr(0), AtomStrLength)

     lnResult = GlobalGetAtomName (nAtom, @lpBuffer, AtomStrLength)



     If lnResult > 0

          Insert Into cs Values (nAtom, lnResult, Left(lpBuffer, lnResult))

     Endif

Endfor

Select cs



If Seek(tcAtom)

    Messagebox("MYPRG is already running!"+CHR(10)+;

    "If you shut the program down illegally please restart windows!","MYPRG",16)

    Quit

ELSE

    natom2 = GlobalAddAtom(tcAtom)

ENDIF

******************test run******************************************

اینطوری هم موقع خروج حذف کنید:

= GlobalDeleteAtom(natom2)

[hamed_m]

پنجره تون رو به بالاترین سطح بیارید:

Declare Long FindWindow in User32 String, String

Declare BringWindowToTop in User32 Long nhWnd



hWnd = FindWindow(Null, This.Caption)

BringWindowToTop(hWnd)

[kia1349]

خیلی خوبه ادامه بدید

[hamed_m]

ممنون جناب کیا.
اینهم برای خواندن یک صفحه اینترنتی:

lcURL="http://yahoo.com/"

objHTTP = CreateObject("MSXML2.XMLHTTP")

objHTTP.Open("GET", lcURL, .f.)

objHTTP.Send

lcInnerHtml=(objHTTP.ResponseText)

? lcInnerHtml

[hamed_m]

فعال کردن خروج با استفاده از Alt+F4 :
کافیه کد زیر رو به main.prg اضافه کنید:

ON KEY LABEL ALT+F4 Quit

[hamed_m]

پیش آمده که موقع خروج از برنامه به مشکل بر بخورید؟ یه راه حل ساده اما نه چندان استاندارد:

DECLARE ExitProcess IN WIN32API INTEGER

ExitProcess(0)

[hamed_m]

جلوگیری از سفید شدن یا به هم ریختن گرید:

thisform.grid1.RecordSource=""



* kaaretoon ro ba jadvaltoon anjaam bedid



thisform.grid1.RecordSource="jadvaletoon"

thisform.grid1.refresh

[hamed_m]

ارور هندلر:

ON ERROR DO errhand WITH ;

   ERROR( ), MESSAGE( ), MESSAGE(1), PROGRAM( ), LINENO(1)







PROCEDURE errhand

PARAMETER merror, mess, mess1, mprog, mlineno

myMessage='Error number: ' + LTRIM(STR(merror))+ CHR(10) ;

        + 'Error message: ' + mess + CHR(10); 

        + 'Line: ' + mess1 + CHR(10);

        + 'Line number of error: ' + LTRIM(STR(mlineno)) + CHR(10) 

      STRTOFILE(myMessage, "c:\myexe\error\"+ALLTRIM(DTOS(DATE()))+".txt",.t.  )

ENDPROC 

[rezakhj]

لطفا ادامه دهید ما منتظر کدها هستیم .

[mehran_337]

با کسب اجازه از حامد عزیزم من هم کدهایی که دارم را در این تاپیک که ایده قشنگ ایشان بود می زارم
این کد یک فرم با عکس که از روی هارد می دهیم می سازد و با کارکترها طوری کار می کند که انگار روی عکس برف در حال باریدن است

**************************************************  ********

** Author      : Ramani (Subramanian.G)

**               FoxAcc Software / Winners Software

** Type        : Freeware with reservation to Copyrights

** Warranty    : Nothing implied or explicit

**************************************************  ********

tCaption1 = "Seasons Greetings .. "

tCaption2 = ".. & Happy New Year - Ramani"

tImage = "G:\picture\new pic\ XP Wallpapers\0002.jpg"

=gsGreet(tCaption1,tCaption2,tImage)

**********************************************





**********************************************

** gsGreet.PRG

** How to run ..

**   =gsGreet(tCaption1,tCaption2,tImage)

** You can use your own Bmp or Gif file

** You can also save the picture above as xmas.jpg

** by right click mouse over it and save that

** in the same place as you save this prg.

**********************************************

* Greetings Card form

PROCEDURE gsGreet

PARAMETERS tCaption1, tCaption2, tImage



PUBLIC oform1

oform1=NEWOBJECT("gForm",'','',tCaption1,tCaption2  , tImage)

oForm1.TitleBar = 0  && if you wish to have no titlebar

oform1.Show

RETURN

**********************************************

**********************************************

DEFINE CLASS gForm AS form



    Height = 454

    Width = 633

    DoCreate = .T.

    BackColor = RGB(0,0,128)

    Name = "Greetings"

    cSnow = "'"

    nSnow = 0

    nSnowFont = 20



Add object Text1 as label with ;

    AutoSize = .T., ;

    BackStyle = 0, ;

    FontBold = .T., ;

    FontItalic = .T., ;

    FontSize = 24, ;

    Left = 24, ;

    Name = "Text1"



Add object Text2 as label with ;

    AutoSize = .T., ;

    BackStyle = 0, ;

    FontBold = .T., ;

    FontItalic = .T., ;

    FontSize = 24, ;

    Left = 96, ;

    Name = "Text2"



PROCEDURE init

LPARAMETERS tCaption1, tCaption2, tGif



   IF EMPTY(tCaption2)

      tCaption2 = "from Ramani (Subramanian.G)"

   ENDIF

   IF EMPTY(tCaption1)

      tCaption1 = "Greetings !!!"

   ENDIF

   WITH ThisForm

      .Text1.Caption = tCaption1

      .Text2.Caption = tCaption2

      .Text1.Top = .Height - 72

      .Text2.Top = .Height -36

      IF !FILE(tGif)

         .cSnow = "*"

         .nSnowFont = 36

      ELSE

         .BackColor = RGB(253,254,249)

         .ADDOBJECT("Image1","Image")

         WITH .Image1

            .Picture = tGif

            .Stretch = 2

            .Width = ThisForm.Width

            .Height = ThisForm.Height - 72

            .Top = 0

            .Left = 0

            .Zorder(1)

            .Visible = .t.

         ENDWITH

      ENDIF

      **

      .nSNow = 50  && Max of t*i

      x = 1

      FOR t=0 TO 5

         FOR I=1 TO 10

            cI = ALLTRIM(STR((t*10)+I))

            .ADDOBJECT("greet&cI","LABEL")

            .greet&cI..AutoSize = .T.

            .greet&cI..BackStyle = 0

            .greet&cI..FontSize = ThisForm.nSnowFont

            .greet&cI..Caption = ThisForm.cSnow

            .greet&cI..Left = (i*50) + (10*rand())

            .greet&cI..Top = (t*90) + (10*rand())

            .greet&cI..Name = "greet&cI"

            .greet&cI..ForeColor = RGB(255,255,255)

            .greet&cI..Visible = .t.

         ENDFOR

      ENDFOR

      .ADDOBJECT("Timer1","Timer1")

   ENDWITH

ENDPROC



PROCEDURE KeyPress

LPARAMETERS nKeyCode, nShiftAltCtrl

   IF nKeyCode = 27

      ThisForm.Release()

   ENDIF

ENDPROC



ENDDEFINE

**********************************************

DEFINE CLASS timer1 AS Timer

    Interval = 100

    Name = "Timer1"



PROCEDURE Timer

   WITH ThisForm

      .Text2.forecolor = .Text1.ForeColor

      DO CASE

         CASE .Text1.forecolor=16711680

              .Text1.forecolor=255

         CASE .Text1.forecolor=255

              .Text1.forecolor=8421376

         CASE .Text1.forecolor=8421376

              .Text1.forecolor=8388863

         OTHERWISE

             .Text1.forecolor=16711680

      ENDCASE

   ENDWITH

   **

   FOR i= 1 TO ThisForm.nSnow

      zm_g='thisform.greet'+alltrim(str(i))

      zm_gl=zm_g+'.left'

      IF &zm_gl<572

         &zm_gl=&zm_gl+10*rand()

      ELSE

         &zm_gl=1

      ENDIF

      zm_gl=zm_g+'.top'

      IF &zm_gl<392

         &zm_gl=&zm_gl+10*rand()

      ELSE

         &zm_gl=1

      ENDIF

   ENDFOR

ENDPROC

ENDDEFINE

**********************************************

** EOF

**********************************************

[mehran_337]

این کد هم خیلی به درد می خوره . اول یک پروژه را باز کنید و بعد این کد رو اجرا کنید . تمام جداول را باز می کنه و ساختارشونو در یک فایل در اختیارتون قرار می ده . به نظر من یکی از فایده هاش می تونه در بازسازی فایل های ایندکس باشه . من در برنامه هام نیاز به این دارم که cdx ها دوباره ساخته بشه مجبورم ساختار همه جداولمو دستی دربیارم.
اما با این کد ....

**************************************************  ********

** Author      : Ramani (Subramanian.G)

**               FoxAcc Software / Winners Software

** Type        : Freeware with reservation to Copyrights

** Warranty    : Nothing implied or explicit

** Last modified : 15 December, 2002

**************************************************  ********

** How to use .... (Example)

** 1. Copy the gs_TableS.PRG routine as given below

** 2. Open up your project in your project manager

** 3. Run the programme from Command window by typing

**    DO gs_TableS

** 4. All the open projects Tables are involved

**    SO if you want for one project..

**    .... only keep that project open.

**************************************************  ********

** PROCEDURE gs_Tables

**

IF Application.Projects.Count()=0

   =MESSAGEBOX("No Project Open.Exiting... ", ;

          0+16,"No Active Project Available")

   RETURN

ENDIF

CLOSE TABLES ALL

myFile=PUTFILE("Select a file name for the Table Structure","c:\my documents","txt")

IF EMPTY(myFile)

   RETURN

ENDIF

myFile = ALLTRIM(myFile)

IF ATC(".",myFile) > 0

   myFile = LEFT(myFile,ATC(".",myFile)-1)+".txt"

ELSE

   myFile = myFile+".txt"

ENDIF

ERASE (myFile)

**

LOCAL cTable, i, p

FOR p = 1 TO application.Projects.Count

   FOR i =  1 TO application.Projects(p).Files.Count

      cTable = application.Projects(p).Files(i).NAME

      IF UPPER(JUSTEXT(cTable)) = "DBC"

         OPEN DATABASE (cTable)

         DISPLAY TABLES TO (myFile) ADDITIVE NOCONSOLE

         SELECT objectName FROM (cTable) ;

                WHERE UPPER(objectType)="TABLE" ;

                INTO CURSOR myCursor

         SCAN

**          WAIT WINDOW objectName && if you want

            SELECT 0

            USE (myCursor.objectName)

            DISPLAY STRUCTURE TO (myFile) ADDITIVE NOCONSOLE

            USE

            SELECT myCursor

         ENDSCAN

         USE IN myCursor

      ENDIF

      IF UPPER(JUSTEXT(cTable)) = "DBF"

**       WAIT WINDOW cTable && if you want wait status

         USE (cTable)

         DISPLAY STRUCTURE TO (myFile) ADDITIVE NOCONSOLE

         USE

      ENDIF

   ENDFOR

ENDFOR

CLOSE TABLES ALL

MODIFY FILE (myFile)

RETURN

**************************************************  ********

** EOF

**************************************************  ********

[mehran_337]

چاپ تصویر

LPARAMETERS tcImage

*tcImage = GETPICT()

*--------------------------------------------------------

* VFP code that shows how to print image files.

* Code adapted from Microsoft Knowledge Base article 

* 895602. http://support.microsoft.com/kb/895602/EN-US/

*

* Most of the codes and comments below come from 

* Trevor Hancock, from MS

*--------------------------------------------------------

LOCAL lnArea

lnArea = SELECT() 

CREATE CURSOR ReportTemp (ImageFile c(150))

INSERT INTO ReportTemp VALUES (tcImage)

*-- This calls a function that makes a report programmatically.

*-- This is included here just to make sure that this sample can be run

*-- as-is, without asking the developer to manually create a report.

MakeReport()

*-- Make sure that the cursor is selected,

*-- and then run the report to preview using

*-- the instance of our Report Listener.

SELECT ReportTemp

REPORT FORM ___ImageReport PREVIEW

DELETE FILE "___ImageReport.fr*"

SELECT (lnArea)

RETURN

*--------------------------------

*-- This function programmatically creates a report

*-- with an OLE Bound control and other fields. This is included

*-- only for demonstration purposes so this article code can stand-alone.

*-- Typically, you would create your own report manually by using

*-- the report designer.

FUNCTION MakeReport

CREATE REPORT ___ImageReport FROM ReportTemp

*-- Open the report file (FRX) as a table.

USE ___ImageReport.FRX IN 0 ALIAS TheReport EXCLUSIVE

SELECT TheReport

*-- Remove from the FRX the auto generated fields and labels

DELETE FROM TheReport WHERE ObjType = 5 AND ObjCode = 0 && Remove the Labels

DELETE FROM TheReport WHERE ObjType = 8 AND ObjCode = 0 && Remove the Fields



*-- Add a Picture/OLE Bound control to the report by inserting a

*-- record with appropriate values. Using an object that is based on the EMPTY

*-- class here and the GATHER NAME class later to insert the record makes it easier to

*-- see which values line up to which fields (when compared to a large

*-- SQL-INSERT command).

LOCAL loNewRecObj AS EMPTY

loNewRecObj = NEWOBJECT( 'EMPTY' )

ADDPROPERTY( loNewRecObj, 'PLATFORM', 'WINDOWS' )

ADDPROPERTY( loNewRecObj, 'Uniqueid', SYS(2015) )

ADDPROPERTY( loNewRecObj, 'ObjType', 17 ) && "Picture/OLE Bound Control"

ADDPROPERTY( loNewRecObj, 'NAME', 'ReportTemp.ImageFile' ) && The object ref to the IMAGE object.

ADDPROPERTY( loNewRecObj, 'Hpos', 100)

ADDPROPERTY( loNewRecObj, 'Vpos', 600)

ADDPROPERTY( loNewRecObj, 'HEIGHT', 100000)

ADDPROPERTY( loNewRecObj, 'WIDTH', 100000)

ADDPROPERTY( loNewRecObj, 'DOUBLE', .T. ) && Picture is centered in the "Picture/OLE Bound Control"

ADDPROPERTY( loNewRecObj, 'Supalways', .T. )

*-- For the Picture/OLE Bound control, the contents of the OFFSET field specify whether

*-- Filename (0), General field name (1), or Expression (2) is the source.

ADDPROPERTY( loNewRecObj, 'Offset', 2 )

*-- Add the Picture/OLE Bound control record to the report.

APPEND BLANK IN TheReport

GATHER NAME loNewRecObj MEMO

*-- Clean up and then close the report table.

PACK MEMO

USE IN SELECT( 'TheReport' )

ENDFUNC

[mehran_337]

این کد مشخصات تصویر را بر می گرداند

LOCAL lcSource, lcInfo, lnWidth, lnHeight, lnHorRes, lnVerRes, lnPixForm

lcSource = GETPICT()



LOCAL loImage AS GpImage OF ffc/_gdiplus.vcx

loImage = NEWOBJECT("GpImage", HOME() + "ffc/_gdiplus.vcx")

loImage.CreateFromFile(lcSource)

 

lnWidth  = loImage.ImageWidth

lnHeight = loImage.ImageHeight

lnHorRes = loImage.HorizontalResolution

lnVerRes = loImage.VerticalResolution

lnPixForm = loImage.PixelFormat

lcPixForm = GetPixFormatName(lnPixForm)



lcInfo = "Image : " + lcSource + CHR(13) + CHR(13) +;

  "Width : " + TRANSFORM(lnWidth) + " pixels" + CHR(13) +;

  "Height : " + TRANSFORM(lnWidth) + " pixels" + CHR(13) +;

  "Pixel Format : " + lcPixForm + CHR(13) +;

  "Hor. Resol : " + TRANSFORM(lnHorRes) + " pixels/inch" + CHR(13) +;

  "Ver. Resol : "  + TRANSFORM(lnVerRes) + " pixels/inch" + CHR(13)



MESSAGEBOX(lcInfo, 64, "Image Information")

RETURN



PROCEDURE GetPixFormatName(nPix)

   DO CASE 

   CASE nPix = 0x00030101

      RETURN "1bppIndexed"

   CASE nPix = 0x00030402

      RETURN "4bppIndexed"

   CASE nPix = 0x00030803

      RETURN "8bppIndexed"

   CASE nPix = 0x00101004

      RETURN "16bppGrayScale"

   CASE nPix = 0x00021005

      RETURN "16bppRGB555"

   CASE nPix = 0x00021006

      RETURN "16bppRGB565"

   CASE nPix = 0x00061007

      RETURN "16bppARGB1555"

   CASE nPix = 0x00021808

      RETURN "24bppRGB"

   CASE nPix = 0x00022009

      RETURN "32bppRGB"

   CASE nPix = 0x0026200A

      RETURN "32bppARGB"

   CASE nPix = 0x000E200B

      RETURN "32bppPARGB"

   CASE nPix = 0x0010300C

      RETURN "48bppRGB"

   CASE nPix = 0x001C400E

      RETURN "64bppPARGB"

   OTHERWISE 

      RETURN "Unidentified"

   ENDCASE 

ENDPROC

[mehran_337]

این هم یک گرید با سطر های رنگی

Public oForm

oForm = Newobject("form1")

oForm.Show

Return

**************************************************  ********

* class definition for form1

Define Class form1 As Form

   Top = 0

   Left = 0

   Height = 340

   Width = 381

   DoCreate = .T.

   Caption = "Grid Highlight"

   Name = "form1"

   ShowTips = .T.

   Procedure Init

   Public gvTypeA,gvTypeD,gvTypeR

   gvTypeA = Rgb(255,0,0)

   gvTypeD = Rgb(0,0,128)

   gvTypeR = Rgb(64,128,128)

   Select temp

   Locate

   This.AddObject('grid1','grid1')

   This.grid1.Visible = .T.

   Endproc

   Procedure Load

   * create cursor for temporary data

   Create Cursor temp (cType c(1),cDesc c(40),nRand i)

   lnFlds = Afields(laFlds,'temp')

   For lnY = 1 To lnFlds

      lcNdxNm = laFlds(lnY,1)

      Index On &lcNdxNm Tag &lcNdxNm

   Next

   * create index for all fields

   For lnX = 1 To 9

      m.cType = 'R'

      m.cDesc = m.cType + Space(2) + 'Description ' + Alltrim(Str(lnX))

      m.nRand = Rand() * 100

      Insert Into temp From Memvar

   Next

   For lnX = 1 To 9

      m.cType = 'A'

      m.cDesc = 'Description ' + m.cType + Space(2) + Alltrim(Str(lnX))

      m.nRand = Rand() * 100

      Insert Into temp From Memvar

   Next

   For lnX = 1 To 9

      m.cType = 'D'

      m.cDesc = Alltrim(Str(lnX)) + Space(2) + m.cType + Space(2) + 'Description'

      m.nRand = Rand() * 100

      Insert Into temp From Memvar

   Next

   Endproc

   Procedure Unload

   Release gvTypeA,gvTypeD,gvTypeR

   Endproc

Enddefine

* end class definition for form1

**************************************************  ********

* class definition for grid

Define Class grid1 As Grid

   ColumnCount = 3

   FontSize = 8

   DeleteMark = .F.

   Height = 313

   Left = 13

   Panel = 1

   RowHeight = 17

   Top = 12

   Width = 354

   Name = "Grid1"

   GridLines = 0

   Procedure Init

   With This

      lcForeColor = "Iif(cType='R',gvTypeR,Iif(cType='D',gvTypeD,gvTyp  eA))"

      .RecordSource = 'temp'

      .HighlightStyle = 2

      .SetAll('DynamicForeColor',lcForeColor,'column')

      .HighlightBackColor = Evaluate(.Column1.DynamicForeColor)

      .HighlightForeColor = Rgb(255,255,255)

      .SetAll('SelectedBackColor',.HighlightBackColor ,'textbox')

      .SetAll('SelectedForeColor',.HighlightForeColor ,'textbox')

      With .Column1

         .ControlSource = 'cType'

         .FontSize = 8

         .Width = 36

         .RemoveObject('header1')

         .AddObject('header1','header1')

         .header1.Caption = "Type"

      Endwith

      With .Column2

         .ControlSource = 'cDesc'

         .FontSize = 8

         .Width = 206

         .RemoveObject('header1')

         .AddObject('header1','header1')

         .header1.Caption = "Description"

      Endwith

      With .Column3

         .ControlSource = 'nRand'

         .FontSize = 8

         .Width = 75

         .RemoveObject('header1')

         .AddObject('header1','header1')

         .header1.Caption = "Number"

      Endwith

      .Refresh

   Endwith

   Endproc

   Procedure AfterRowColChange

   Lparameters nColIndex

   With This

      .HighlightBackColor = Evaluate(.Column1.DynamicForeColor)

      .HighlightForeColor = Rgb(255,255,255) && white

      .SetAll('SelectedBackColor',.HighlightBackColor ,'textbox')

      .SetAll('SelectedForeColor',.HighlightForeColor ,'textbox')

   Endwith

   Endproc

Enddefine

* end class definition for grid

**************************************************  ********

* class definition for Header

Define Class header1 As Header

   Tag = 'A'

   FontSize = 8

   ToolTipText = 'Click here to sort'

   Procedure Click

   Local lcNdx,lcOrder,lcAlias

   With This

      If .Tag = 'A'

         lcOrder = 'Ascending'

         .Tag = 'D'

      Else

         lcOrder = 'Descending'

         .Tag = 'A'

      Endif

      lcNdx = .Parent.ControlSource

      lcAlias = .Parent.Parent.RecordSource

      Select (lcAlias)

      Set Order To &lcNdx &lcOrder

      .Parent.Parent.Refresh

   Endwith

   Endproc

Enddefine

* end class definition for Header

[mehran_337]

این کد تمام چاپگر ها تعریف شده در سیستم را به همراه پورت هر یک چاپ می کند

LOCAL wshNetwork As "WScript.Network" &&WshNetwork

LOCAL Printers As Object &&WshCollection

LOCAL i As Integer



wshNetwork = CreateObject("WScript.Network")

Printers = wshNetwork.EnumPrinterConnections



For i = 1 To Printers.Count - 1 Step 2

    ? "Printer Name: " 

    ?? Printers.Item(i)

    ? "Port: " 

    ?? Printers.Item(i - 1)

Endfor



? "Total of Installed Printers: " 

?? INT(Printers.Count / 2)



Printers = .null.

wshNetwork = .null.

[hamed_m]

ممنون مهران عزیز. کدهای بسیار جالبی بودند. امید که من هم بتونم با کد خدمت برسم.

[mehran_337]

خواهش می کنم .
این بنای خوب و خودت پایه ریزی کردی . البته کدهای شما بیشتر در زمینه کار با توابع ویندوز بود که برای من هم خیلی جالب بود و هم اینکه جایی ندیده بودم چون همیشه فکر می کردم فاکس پرو با توابه ویندوزی مشکل داره . اما به لطف دوستان خوبی مثل شما ها دیدم عوض شد . به هر حال این تاپیک مورد علاقه من هست . پس ولش نکن . من هم تا حد امکان کمک می کنم
موفق باشی

[kia1349]

البته فقط شما دو نفر نیستید. ما هم داریم استفاده میکنیم .فقط صداشو در نیاوردیم

[mehran_337]

آقا رضا ! این هم از اون حرفهاستا
شما که همه اینها رو موقعی کار می کردید که ما داشتیم reset کردن و یاد می گرفتیم.
جوابهای شما باعث دلگرمی ماست . خیلی خوشحال می شم وقتی میام و می بینم جواب می دین یه جورایی آدم برای مطلب گذاری مشتاق تر می شه.

[reza1357]

با سپاس و درود بی کران بر شما مهران جان
کدهای بسیار جالبی بودند. دستت درد نکنه.

[hamed_m]

نام کامپیوتر:

DECLARE INTEGER GetComputerName ;

     IN WIN32API ;

     STRING@ cComputerName,;

     INTEGER@ nSize



lcComputer=SPACE(80)

lnSize=80



=GetComputername(@lcComputer,@lnSize)

IF lnSize < 2

   lcComputer=""

ENDIF   



? lcComputer

[mehran_337]

نام تابع را همراه مسیر بدهید اگر آن مسیر وجود داشته باشد مقدار true را بر می گرداند

	*

	*	IsDir( <cDirectory> ) -> boolean

	*

	*	Return TRUE if exist directory <cDirectory>

	*

	FUNCTION isDIR( cDir )

		LOCAL olderror, oldPath, lOk



		IF NOT EMPTY(cDir)

			lOk = .T.

			olderror = ON('ERROR')

			oldPath = SYS(5)+CURDIR()

			ON ERROR lOk = .F.

			SET DEFAULT TO (cDir)

			ON ERROR &olderror

			SET DEFAULT TO (oldPath)

		ELSE

			lOk = .F.

		ENDIF



		RETURN lOk



	ENDFUNC

[mehran_337]

این کد شاید واسه خیلی ها جالب باشه . تمام مشخصات چاپگرهای موجود حتی در شبکه رو نمایش می ده

LOCAL wshNetwork As "WScript.Network" &&WshNetwork

LOCAL Printers As Object &&WshCollection

LOCAL i As Integer



wshNetwork = CreateObject("WScript.Network")

Printers = wshNetwork.EnumPrinterConnections



For i = 1 To Printers.Count - 1 Step 2

    ? "Printer Name: " 

    ?? Printers.Item(i)

    ? "Port: " 

    ?? Printers.Item(i - 1)

Endfor



? "Total of Installed Printers: " 

?? INT(Printers.Count / 2)



Printers = .null.

wshNetwork = .null.

[mehran_337]

توی این سایت وقتی صحبت از نحوه استفاده از بانک می شد به این نتیجه رسیدیم که یکسری از دستورات رو باید ابتدای هر برنامه بعنوان " آماده سازی برنامه ... " اجرا کنیم یکی از این دستورات pack برای تمام بانکهاست . شاید نوشتن نام تمام بانک ها کار مشکلی باشد و اینکه بعدا بانکی را اضافه کنیم یادمان برود . این کد تمام بانکهای موجود در شاخه مورد نظر را pack می کند
فقط کافیه مسیر بدهیم خودش تمام جداول را پیدا می کند

PARAMETERS myDataDir

SET EXCLUSIVE ON

LOCAL aFiles, nCount, I

DIMENSION aFiles(1,1)

nCount = ADIR(aFiles,mydataDir+"\"+"*.DBF")

=ASORT(aFiles,1)

I=1

FOR I = 1 TO nCount

   WAIT WINDOW "Reindexing "+aFiles(I,1)+ ;

               " ... Please wait" NOWAIT

   SELECT 0

   USE mydataDir+"\"+(aFiles(I,1))

   PACK

   USE

   WAIT CLEAR

ENDFOR

SET EXCLUSIVE OFF

RETURN

[rezamim]

توی این سایت وقتی صحبت از نحوه استفاده از بانک می شد به این نتیجه رسیدیم که یکسری از دستورات رو باید ابتدای هر برنامه بعنوان " آماده سازی برنامه ... " اجرا کنیم یکی از این دستورات pack برای تمام بانکهاست . شاید نوشتن نام تمام بانک ها کار مشکلی باشد و اینکه بعدا بانکی را اضافه کنیم یادمان برود . این کد تمام بانکهای موجود در شاخه مورد نظر را pack می کند
فقط کافیه مسیر بدهیم خودش تمام جداول را پیدا می کند

PARAMETERS myDataDir

SET EXCLUSIVE ON

LOCAL aFiles, nCount, I

DIMENSION aFiles(1,1)

nCount = ADIR(aFiles,mydataDir+"\"+"*.DBF")

=ASORT(aFiles,1)

I=1

FOR I = 1 TO nCount

   WAIT WINDOW "Reindexing "+aFiles(I,1)+ ;

               " ... Please wait" NOWAIT

   SELECT 0

   USE mydataDir+"\"+(aFiles(I,1))

   PACK

   USE

   WAIT CLEAR

ENDFOR

SET EXCLUSIVE OFF

RETURN

و اگر برنامه تحت شبکه باشه ؟!

[hamed_m]

آقا رضا اصولا وقتی برنامه تحت شبکه باشه استفاده EXCLUSIVE از تیبل ها بسیار مشکل سازه. در واقع باید اکسس تمام یوزرها رو قطع کنید. ممکن هست اما خیلی جالب نیست. شاید استفاده از یه دیتابیس اینجین راه بسیار مناسب تری باشه.



باز کردن یک صفحه اینترنتی با استفاده از بروزر پیش فرض:

LPARAMETERS pcURL

LOCAL lnRes

lnRes = ShellExec(pcURL,'','OPEN','')  && GTv10.00 wgcs

if lnRes <= 32  && v10.00 wgcs

  =MessageBox('Error number '+alltrim(str(lnRes))+' while opening '+crlf;

              + pcURL, mbxOk, 'Failed')  && v10.00 wgcs

endif  





FUNCTION ShellExec

LPARAMETERS lcFileName, lcWorkDir, lcOperation, pcParameters

LOCAL pp, lcParam

pp = pCount()          && LAS v9b1w  wgcs

if pp>3                    && LAS v9b1w  wgcs

  lcParam = pcParameters   && LAS v9b1w  wgcs

else                       && LAS v9b1w  wgcs

  lcParam = ''

endif

lcWorkDir=IIF(type("lcWorkDir")="C",lcWorkDir,"")

lcOperation=IIF(type("lcOperation")="C",lcOperatio  n,"Open")

DECLARE INTEGER ShellExecute ;    

    IN SHELL32.DLL ;    

    INTEGER nWinHandle,;

    STRING cOperation,;    

    STRING cFileName,;    

    STRING cParameters,;

    STRING cDirectory,;    

    INTEGER nShowWindow

RETURN ShellExecute(0,lcOperation,lcFilename,lcParam,lcWo  rkDir,1)

[rezamim]

آقا رضا اصولا وقتی برنامه تحت شبکه باشه استفاده EXCLUSIVE از تیبل ها بسیار مشکل سازه. در واقع باید اکسس تمام یوزرها رو قطع کنید. ممکن هست اما خیلی جالب نیست. شاید استفاده از یه دیتابیس اینجین راه بسیار مناسب تری باشه.

راهی که من استفاده میکنم اینه
1 - چک میکنم که بانکها قابل باز شدن بصورت انحصاری هستند یا نه . اگه نه پس بیخیال
2 - اگه میشه پس سریع همه رو بصورت انحصاری باز میکنم و pack و reindex . اگه در این زمان کاربری بخواهد وارد شود پیغام میدم که بانکها دارند بازسازی میشوند ، مجددا وارد شوید .
تا حالا هم عالی جواب گرفتم

[mehran_337]

با سلام به همه :
اول اینکه بازهم چندروز از دیدن این سایت محروم بودم نمی دونم چه اتفاقی داره میفته . اما امید وارم مشکل اساسی نباشه.اگه کسی می دونه بهم بگه که چرا این مدت همش سایت مشکل داره.
آقای حیدری کیا ! دیدن پیام تشکر شما باعث شرمندگی من می شه . چون ما و همه اعضای سایت متشکر از شما و زحمات شما هستیم ایکاش وقت اجازه می داد و با جان و دل راه شما را ادامه می دادیم.
آقای رضا میم ! ما قابل تعارف شما نیستیم اما متاسفانه اطلاعات من در شبکه زیر صفره امیدوارم با کمک دوستان با صفایی مثل شما بنده را یاری کنید تا کمی مطالب شبکه ای یاد بگیرم.
و حامد عزیز که از سرزمینی دیگر عرق وطن دوستی اش یاری کننده هموطنان ایرانی اش می باشد بانی خیر این موضوع می باشند و تا حالا پشتیبان و معلم من در زمینه تکه کدهای واقعا جالب ایشان می باشد.
انشاءالله همچنان به زکات علم خود بپردازیم

[rezaTavak]

راهی که من استفاده میکنم اینه
1 - چک میکنم که بانکها قابل باز شدن بصورت انحصاری هستند یا نه . اگه نه پس بیخیال
2 - اگه میشه پس سریع همه رو بصورت انحصاری باز میکنم و pack و reindex . اگه در این زمان کاربری بخواهد وارد شود پیغام میدم که بانکها دارند بازسازی میشوند ، مجددا وارد شوید .
تا حالا هم عالی جواب گرفتم

چطوری چک میکنید؟

[hamed_m]

البته میشه عملیات یوزرها رو هم متوقف کرد:
1- یه تایمر در برنامه اجرایی وجود فایلی روی سرور رو بررسی میکنه.
2- اگر وجود نداشت برنامه بصورت عادی کارش رو میکنه.
3- اگر وجود داشت از یوزر درخواست ذخیره تغییرات رو میکنه و بعد تیبلهای مورد استفاده اش رو میبنده.
4- یه تایمر دیگه چک میکنه که تیبلها مورد استفاده هستند یا نه. اگر نه کار پک انجام میشه و اون فایل روی سرور پاک میشه.
5- به همه اجازه اجرای برنامه اصلی داده میشه.
کمی مشکله پیاده سازیش. اما ممکنه.


طریقه چک کردن اینکه جدول قابلیت باز شدن EXCLUSIVE داره یا نه:

USE '\\server\data\yourtable.dbf' 

lcstatus=SYS(2011) 

llretwert=IIF(UPPER(lcstatus)="EXCLUSIVE",.T.,.F.)

 

IF (llretwert==.F.)

* kasi dar hale estefadeh az jadvaleh



ELSE

* jadval EXCLUSIVE dar ekhtiare shomast

* baghieh code pack



ENDIF

خاطرتون نره که ارورها رو هندل کنید:

ON ERROR do excl_error





FUNCTION excl_error 

 RETURN

*EOF excl_error

وگرنه جالب نمیشه. و بعد هم ارور هندلر رو دوباره ست کنید. امیدوارم مورد استفاده قرار بگیره.





پ ن - مهران عزیز چوبکاری نفرمایید. ممنون از لطفتون.

[rezamim]

چطوری چک میکنید؟

اگر برنامه دفترچه تلفن رو دیده باشید ، در اول برنامه یکسری کارهایی رو انجام میده مثل :
1 - چک کردن وجود بانکها
2 - چک کردن وجود ایندکسها
3 - چک کردن باز شدن سالم بانکها همراه با ایندکسها
و . . .

در همین مرحله یکی از کارها توسط این تابع هست

FUNCTION CanOpenExclusive

********************************************

   RtrnCanOpen  = .T.

   ErrorCommand = ON( 'ERROR' )

   ON ERROR STORE .F. TO RtrnCanOpen

   FOR Count = 1 TO NoOfDbfs

      USE DbfsPath + IIF( Count > RootDbfs,ActiveDbfYear,'')+ AliasName(Count) + '.DAT' EXCLUSIVE

      IF RtrnCanOpen = .F.

         EXIT

      ENDIF

   ENDFOR

   CLOSE DATABASES

   ON ERROR &ErrorCommand

RETURN( RtrnCanOpen )

[mehran_337]

سلام
حالا که این بحث پیش اومد من یه سوالی دارم
دستور pack توی شبکه چطور باید استفاده کرد.
وسوال دوم اینکه وقتی از delete استفاده میشه و هنوز پک نکردیم بازهم دستورتی مانند RECCOUNT , COUNT و امثال اینها عدد درستی را نمی دهند چون با دکوردهای DEL شده محاسبه می کنند البته من قبل از هر DELET دستور BLANK می کنم و بجای RECCOUN از دستور <نام فیلد>COUNT FOR !EMPT استفاده می کنم که زیاد برایم جالب نیست. اگه می شه راهنماییم کنید

[mehran_337]

این کد لیست تمام شاخه ها و زیر شاخه ها را در یک جدول ذخیره می کند.

**************************************************  *******

** Author   : Ramani (Subramanian.G)

**            FoxAcc Software / Winners Software

**            ramani_vfp@yahoo.com

** Type     : Freeware with reservation to Copyrights

** Warranty : Nothing implied or explicit

** Last modified : 31 January, 2003

**************************************************  *******

** The following uses Filer.DLL and

**      extracts all files in a directory as a cursor.

** How to run :  Save this as dir2Cursor.prg

**               =dir2Cursor(cDir)

**************************************************  *******

** FUNCTION dir2cursor

PARAMETERS pDir

IF PARAMETERS() < 1 OR EMPTY(pDir)

   RETURN

ENDIF

pDir = ADDBS(ALLTR(pDir))

CREATE CURSOR filename (cfilename c(128))

omyfiler = CREATEOBJECT('Filer.FileUtil')

omyfiler.searchpath = pDir    && Search Directory

omyfiler.subfolder = 1 && 1=add all subdirectories else 0

oMyFiler.SortBy = 0

omyfiler.FIND(0)

LOCAL ncount

ncount = 1

FOR nfilecount = 1 TO omyfiler.FILES.COUNT

    IF omyfiler.FILES.ITEM(nfilecount).NAME = "." OR ;

       omyfiler.FILES.ITEM(nfilecount).NAME = ".."

       LOOP

    ENDIF

    APPEND BLANK

    REPLACE cfilename ;

       WITH UPPER(omyfiler.FILES.ITEM(nfilecount).PATH)+ ;

            UPPER(omyfiler.FILES.ITEM(nfilecount).NAME)

ENDFOR

BROW

**************************************************  *******

* EOF

[hamed_m]

مهران عزیز،
با set deleted on هم همین نتایج رو میگیرید؟

[hamed_m]

ورژن ویندوز:

http://fox.wikis.com/wc.dll?Wiki~GetWindowsVersion~VFP

[mehran_337]

آره حامد جان!
مشکل من همینه که وقتی set delete on هم هست تعداد رکورد و بعضی از توابع را با رکوردهای حذف شده محاسبه می کنه اگه میشه راهنماییم کنین

[hamed_m]

count for !deleted() to notdeleted



? notdeleted

[mehran_337]

این کد اختلاف زمان بین دو ساعت را بر می گرداند:

FUNCTION TimeDif

   PARAMETERS tDateTime1, tDateTime2



   LOCAL lReturn, myHours, myMinutes, mySeconds

   lReturn = .t.



   IF PARAMETERS() # 2

      lReturn = .f.

   ENDIF

   IF ! VARTYPE(tDateTime1) = "T"

      lReturn = .f.

   ENDIF

   IF ! VARTYPE(tDateTime2) = "T"

      lReturn = .f.

   ENDIF

   IF lReturn

      IF tDateTime2 > tDateTime1

         mySeconds = tdateTime2 - tDateTime1

      ELSE

         mySeconds = tdateTime1 - tDateTime2

      ENDIF

      mySeconds=INT(mySeconds)

      cTime = TRANSFORM(INT(mySeconds/3600),"9999")+":"+ ;

              TRANSFORM(MOD(INT(mySeconds/60),60),"99")+":"+ ;

              TRANSFORM(MOD(mySeconds,60),"99")

      WAIT WINDOW "Time Difference = "+cTime

      RETURN cTime

   ELSE

      =MESSAGEBOX("Pass to this function ;

          From DateTime and To DateTime", ;

          0+16,"Wrong Parameters")

	   RETURN lReturn

   ENDIF

[mehran_337]

کلاس adir

**************************************************  ***********************

* FileProps class definition

**************************************************  ***********************

Define Class FileProps As Custom

	cName = Space(0)

	nSize = 0

	dDate = {}

	cTime = Space(0)

	cFlags = Space(0)

	

	dtDateTime = {}

	nHour = 0

	nMin = 0

	nSec = 0



	lArchive = .F.

	lHidden = .F.

	lReadOnly = .F.

	lSystem = .F.

	lDir = .F.



	Procedure Init

		Lparameters tcFile, tcFlags

		if ! vartype(m.tcFile)=="C" or EMpty(m.tcFile)

                    tcFile = "*.*"

                endif

		if ! vartype(m.tcFlags)=="C"

                    tcFlags = "HS"

                endif

		Return this.GetFileProps(m.tcFile, m.tcFlags)

	EndProc



	

	Function GetFileProps(tcFile, tcFlags)

		Release aFile

		Dimension aFile[1]

		=ADir(afile, m.tcFile, m.tcFlags) &&1=Name(c), 2=Size(n), 3=Date(d), 4=Time(c), 5=Attr(c)

		

		If vartype(afile[1]) <> 'C'

			=MessageBox("Could not locate file: " + cFile,48,"FileProps Error")

			Return .F.

		Endif

	

		this.cName = afile[1]

		this.nSize = afile[2]

		this.dDate = afile[3]

		this.cTime = afile[4]

		this.cFlags = afile[5]



		this.dtDateTime = Ctot(Dtoc(this.dDate)+this.cTime)

		this.nHour = Hour(this.dtDateTime)

		this.nMin = Minute(this.dtDateTime)

		this.nSec = Sec(this.dtDateTime)



		this.lArchive = "A" $ this.cFlags

		this.lHidden = "H" $ this.cFlags

		this.lReadOnly = "R" $ this.cFlags

		this.lSystem = "S" $ this.cFlags

		this.lDir = "D" $ this.cFlags

	EndFunc

 EndDefine







**************************************************  ******************************

*** Sample Code

**************************************************  ******************************

Local oMyFile as Object, cMyFile as String

oMyFile = .NULL.

cMyFile = Home() + "vfp" + Left(Transform(Version(5)),1) + ".exe"

Clear



oMyFile = CreateObject("FileProps", cMyFile)



If Type('oMyFile') = 'O' and !IsNull(oMyFile)

	? "Name: " + oMyFile.cName

	? "Size: " + Transform(oMyFile.nSize)

	? "Date: " + Transform(oMyFile.dDate)

	? "cTime: " + oMyFile.cTime

	? "cFlags: " + oMyFile.cFlags

	? "DT: " + Transform(oMyFile.dtDateTime)

	? "Hour: " + Transform(oMyFile.nHour)

	? "Min: " + Transform(oMyFile.nMin)

	? "Sec: " + Transform(oMyFile.nSec)

	? "Arch?: " + Transform(oMyFile.lArchive)

	? "Hidden?:" + Transform(oMyFile.lHidden)

	? "RO?: " + Transform(oMyFile.lReadOnly)

	? "System?:" + Transform(oMyFile.lSystem)

	? "Dir?: " + Transform(oMyFile.lDir)

Else

	? "Error Getting File Props"

Endif

Return